From 9a6a3d12a6c32c2c4a331f5084af982b1ca77b1e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 31 Jul 2019 15:45:54 +0100 Subject: Revert "Need to separate out the 0.10 lem library from upcoming 0.11" This reverts commit 3fb4cf236c0d4b15831576faa45c763853632568. --- src/lem_interp/0.11/instruction_extractor.lem | 163 -- src/lem_interp/0.11/interp.lem | 3407 ------------------------- src/lem_interp/0.11/interp_inter_imp.lem | 1338 ---------- src/lem_interp/0.11/interp_interface.lem | 326 --- src/lem_interp/0.11/interp_lib.lem | 1111 -------- src/lem_interp/0.11/interp_utilities.lem | 212 -- src/lem_interp/0.11/sail2_impl_base.lem | 1103 -------- src/lem_interp/0.11/sail2_instr_kinds.lem | 376 --- src/lem_interp/interp_inter_imp.lem | 63 +- src/lem_interp/sail2_instr_kinds.lem | 175 +- 10 files changed, 109 insertions(+), 8165 deletions(-) delete mode 100644 src/lem_interp/0.11/instruction_extractor.lem delete mode 100644 src/lem_interp/0.11/interp.lem delete mode 100644 src/lem_interp/0.11/interp_inter_imp.lem delete mode 100644 src/lem_interp/0.11/interp_interface.lem delete mode 100644 src/lem_interp/0.11/interp_lib.lem delete mode 100644 src/lem_interp/0.11/interp_utilities.lem delete mode 100644 src/lem_interp/0.11/sail2_impl_base.lem delete mode 100644 src/lem_interp/0.11/sail2_instr_kinds.lem (limited to 'src/lem_interp') diff --git a/src/lem_interp/0.11/instruction_extractor.lem b/src/lem_interp/0.11/instruction_extractor.lem deleted file mode 100644 index 11947c17..00000000 --- a/src/lem_interp/0.11/instruction_extractor.lem +++ /dev/null @@ -1,163 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Interp_ast -open import Interp_utilities -open import Pervasives - -type instr_param_typ = -| IBit -| IBitvector of maybe nat -| IRange of maybe nat -| IEnum of string * nat -| IOther - -type instruction_form = -| Instr_form of string * list (string * instr_param_typ) * list base_effect -| Skipped - -val extract_instructions : string -> defs tannot -> list instruction_form - -let rec extract_ityp t tag = match (t,tag) with -(* AA: Hack - | (T_abbrev _ t,_) -> extract_ityp t tag - | (T_id "bit",_) -> IBit - | (T_id "bool",_) -> IBit - | (T_app "vector" (T_args [_; T_arg_nexp (Ne_const len); _; T_arg_typ (T_id "bit")]),_) -> - IBitvector (Just (natFromInteger len)) - | (T_app "vector" (T_args [_;_;_;T_arg_typ (T_id "bit")]),_) -> IBitvector (Just 64) - | (T_app "atom" (T_args [T_arg_nexp (Ne_const num)]),_) -> - IRange (Just (natFromInteger num)) - | (T_app "atom" _,_) -> IRange Nothing - | (T_app "range" (T_args [_;T_arg_nexp (Ne_const max)]),_) -> - IRange (Just (natFromInteger max)) - | (T_app "range" _,_) -> IRange Nothing - | (T_app i (T_args []),Tag_enum max) -> - IEnum i (natFromInteger max) - | (T_id i,Tag_enum max) -> - IEnum i (natFromInteger max) -*) - | _ -> IOther -end - -let extract_parm (E_aux e (_,tannot)) = - match e with - | E_id (Id_aux (Id i) _) -> - match tannot with - | Just(t,tag,_,_,_) -> (i,(extract_ityp t tag)) - | _ -> (i,IOther) end - | _ -> - let i = "Unnamed" in - match tannot with - | Just(t,tag,_,_,_) -> (i,(extract_ityp t tag)) - | _ -> (i,IOther) end -end - -let rec extract_from_decode decoder = - match decoder with - | [] -> [] - | (FCL_aux (FCL_Funcl _ (Pat_aux pexp _)) _)::decoder -> - let exp = match pexp with Pat_exp _ exp -> exp | Pat_when _ _ exp -> exp end in - (match exp with - | E_aux (E_app (Id_aux(Id id) _) parms) (_,(Just (_,Tag_ctor,_,_,_))) -> - Instr_form id (List.map extract_parm parms) [] - | _ -> Skipped end)::(extract_from_decode decoder) -end - -let rec extract_effects_of_fcl id execute = match execute with - | [] -> [] - | FCL_aux (FCL_Funcl _ (Pat_aux (Pat_exp (P_aux (P_app (Id_aux (Id i) _) _) _) _) _)) (_,(Just(_,_,_,Effect_aux(Effect_set efs) _,_))) :: executes -> - if i = id - then efs - else extract_effects_of_fcl id executes - | _::executes -> extract_effects_of_fcl id executes -end - -let rec extract_patt_parm (P_aux p (_,tannot)) = - let t = match tannot with - | Just(t,tag,_,_,_) -> extract_ityp t tag - | _ -> IOther end in - match p with - | P_lit lit -> ("",t) - | P_wild -> ("Unnamed",t) - | P_as _ (Id_aux (Id id) _) -> (id,t) - | P_typ typ p -> extract_patt_parm p - | P_id (Id_aux (Id id) _) -> (id,t) - | P_app (Id_aux (Id id) _) [] -> (id,t) - | _ -> ("",t) end - -let rec extract_from_execute fcls = match fcls with - | [] -> [] - | FCL_aux (FCL_Funcl _ (Pat_aux (Pat_exp (P_aux (P_app (Id_aux (Id i) _) parms) _) _) _)) (_,Just(_,_,_,Effect_aux(Effect_set efs) _,_))::fcls -> - (Instr_form i (List.map extract_patt_parm parms) efs)::extract_from_execute fcls - | _ :: fcls -> - (* AA: Find out what breaks this *) - extract_from_execute fcls -end - -let rec extract_effects instrs execute = - match instrs with - | [] -> [] - | Skipped::instrs -> Skipped::(extract_effects instrs execute) - | (Instr_form id parms [])::instrs -> - (Instr_form id parms (extract_effects_of_fcl id execute))::(extract_effects instrs execute) -end - -let extract_instructions_old decode_name execute_name defs = - let (Just decoder) = find_function defs (Id_aux (Id decode_name) Unknown) in - let (Just executer) = find_function defs (Id_aux (Id execute_name) Unknown) in - let instr_no_effects = extract_from_decode decoder in - let instructions = extract_effects instr_no_effects executer in - instructions - -let extract_instructions execute_name defs = - let (Just executer) = find_function defs (Id_aux (Id execute_name) Unknown) in - let instructions = extract_from_execute executer in - instructions diff --git a/src/lem_interp/0.11/interp.lem b/src/lem_interp/0.11/interp.lem deleted file mode 100644 index 431c1a08..00000000 --- a/src/lem_interp/0.11/interp.lem +++ /dev/null @@ -1,3407 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Pervasives -import Map -import Map_extra (* For 'find' instead of using lookup and maybe types, as we know it cannot fail *) -import Set_extra (* For 'to_list' because map only goes to set *) -import List_extra (* For 'nth' and 'head' where we know that they cannot fail *) -open import Show -open import Show_extra (* for 'show' to convert nat to string) *) -open import String_extra (* for chr *) -import Assert_extra (*For failwith when partiality is known to be unreachable*) - -open import Sail_impl_base -open import Interp_ast -open import Interp_utilities -open import Instruction_extractor - -(* TODO: upstream into Lem *) -val stringFromTriple : forall 'a 'b 'c. ('a -> string) -> ('b -> string) -> ('c -> string) -> ('a * 'b * 'c) -> string -let stringFromTriple showX showY showZ (x,y,z) = - "(" ^ showX x ^ ", " ^ showY y ^ ", " ^ showZ z ^ ")" - -instance forall 'a 'b 'c. Show 'a, Show 'b, Show 'c => (Show ('a * 'b * 'c)) - let show = stringFromTriple show show show -end - -val debug_print : string -> unit -declare ocaml target_rep function debug_print s = `Printf.eprintf` "%s" s - -val intern_annot : tannot -> tannot -let intern_annot annot = - match annot with - | Just (t,_,ncs,effect,rec_effect) -> - Just (t,Tag_empty,ncs,pure,rec_effect) - | Nothing -> Nothing - end - -let val_annot typ = Just(typ,Tag_empty,[],pure,pure) - -let ctor_annot typ = Just(typ,Tag_ctor,[],pure,pure) - -let enum_annot typ max = Just(typ,Tag_enum max,[],pure,pure) - -let non_det_annot annot maybe_id = match annot with - | Just(t,_,cs,ef,efr) -> Just(t,Tag_unknown maybe_id,cs,ef,efr) - | _ -> Nothing -end - -let is_inc = function | IInc -> true | _ -> false end - -let id_of_string s = (Id_aux (Id s) Unknown) - - -let rec {ocaml} string_of_reg_form r = match r with - | Form_Reg id _ _ -> get_id id - | Form_SubReg id reg_form _ -> (string_of_reg_form reg_form) ^ "." ^ (get_id id) -end - -let rec {ocaml} string_of_value v = match v with - | V_boxref nat t -> "$#" ^ (show nat) ^ "$" - | V_lit (L_aux lit _) -> - (match lit with - | L_unit -> "()" - | L_zero -> "0" - | L_one -> "1" - | L_true -> "true" - | L_false -> "false" - | L_num num -> show num - | L_hex hex -> "0x" ^ hex - | L_bin bin -> "0b" ^ bin - | L_undef -> "undefined" - | L_string str-> "\"" ^ str ^ "\"" end) - | V_tuple vals -> "(" ^ (list_to_string string_of_value "," vals) ^ ")" - | V_list vals -> "[||" ^ (list_to_string string_of_value "," vals) ^ "||]" - | V_vector i inc vals -> - let default_format _ = "[" ^ (list_to_string string_of_value "," vals) ^ "]" in - let to_bin () = (*"("^show i ^") "^ *)"0b" ^ - (List.foldr - (fun v rst -> - (match v with - | V_lit (L_aux l _) -> - (match l with | L_one -> "1" | L_zero -> "0" | L_undef -> "u" - | _ -> Assert_extra.failwith "to_bin called with non-bin lits" end) - | V_unknown -> "?" - | _ -> Assert_extra.failwith "to_bin called with non-bin values" end) ^rst) "" vals) in - match vals with - | [] -> default_format () - | v::vs -> - match v with - | V_lit (L_aux L_zero _) -> to_bin() - | V_lit (L_aux L_one _) -> to_bin() - | _ -> default_format() end end - | V_vector_sparse start stop inc vals default -> - "[" ^ (list_to_string (fun (i,v) -> (show i) ^ " = " ^ (string_of_value v)) "," vals) ^ "]:" ^ - show start ^ "-" ^show stop ^ "(default of " ^ (string_of_value default) ^ ")" - | V_record t vals -> - "{" ^ (list_to_string (fun (id,v) -> (get_id id) ^ "=" ^ (string_of_value v)) ";" vals) ^ "}" - | V_ctor id t _ value -> (get_id id) ^ " " ^ string_of_value value - | V_unknown -> "Unknown" - | V_register r -> string_of_reg_form r - | V_register_alias _ _ -> "register_as_alias" - | V_track v rs -> "tainted by {" ^ (list_to_string string_of_reg_form "," []) ^ "} --" ^ (string_of_value v) -end -let ~{ocaml} string_of_value _ = "" - -val debug_print_value_list : list string -> string -let rec debug_print_value_list vs = match vs with - | [] -> "" - | [v] -> v - | v :: vs -> v ^ ";" ^ debug_print_value_list vs -end -val debug_print_value : value -> string -let rec debug_print_value v = match v with - | V_boxref n t -> "V_boxref " ^ (show n) ^ " t" - | V_lit (L_aux lit _) -> - "V_lit " ^ - (match lit with - | L_unit -> "L_unit" - | L_zero -> "L_zero" - | L_one -> "L_one" - | L_true -> "L_true" - | L_false -> "L_false" - | L_num num -> "(Lnum " ^ (show num) ^ ")" - | L_hex hex -> "(L_hex " ^ hex ^ ")" - | L_bin bin -> "(L_bin " ^ bin ^ ")" - | L_undef -> "L_undef" - | L_string str-> "(L_string " ^ str ^ ")" end) - | V_tuple vals -> - "V_tuple [" ^ debug_print_value_list (List.map debug_print_value vals) ^ "]" - | V_list vals -> - "V_list [" ^ debug_print_value_list (List.map debug_print_value vals) ^ "]" - | V_vector i inc vals -> - "V_vector " ^ (show i) ^ - " " ^ (if inc = IInc then "IInc" else "IDec") ^ - " [" ^ debug_print_value_list (List.map debug_print_value vals) ^ "]" - | V_vector_sparse start stop inc vals default -> - let ppindexval (i,v) = (show i) ^ " = " ^ (debug_print_value v) in - let valspp = debug_print_value_list (List.map ppindexval vals) in - "V_vector " ^ (show start) ^ " " ^ (show stop) ^ " " ^ - (if inc = IInc then "IInc" else "IDec") ^ - " [" ^ valspp ^ "] (" ^ debug_print_value default ^ ")" - | V_record t vals -> - let ppidval (id,v) = "(" ^ (get_id id) ^ "," ^ debug_print_value v ^ ")" in - "V_record t [" ^ debug_print_value_list (List.map ppidval vals) ^ "]" - | V_ctor id t k v' -> - "V_ctor " ^ (get_id id) ^ " t " ^ - (match k with | C_Enum n -> "(C_Enum " ^ show n ^ ")" - | C_Union -> "C_Union" end) ^ - "(" ^ debug_print_value v' ^ ")" - | V_unknown -> "V_unknown" - | V_register r -> "V_register (" ^ string_of_reg_form r ^ ")" - | V_register_alias _ _ -> "V_register_alias _ _" - | V_track v rs -> "V_track (" ^ debug_print_value v ^ ") _" - end - -instance (Show value) - let show v = debug_print_value v -end - -let rec {coq;ocaml} id_value_eq strict (i, v) (i', v') = i = i' && value_eq strict v v' -and value_eq strict left right = - match (left, right) with - | (V_lit l, V_lit l') -> lit_eq l l' - | (V_boxref n t, V_boxref m t') -> n = m && t = t' - | (V_tuple l, V_tuple l') -> listEqualBy (value_eq strict) l l' - | (V_list l, V_list l') -> listEqualBy (value_eq strict) l l' - | (V_vector n b l, V_vector m b' l') -> b = b' && listEqualBy (value_eq strict) l l' - | (V_vector_sparse n o b l v, V_vector_sparse m p b' l' v') -> - n=m && o=p && b=b' && - listEqualBy (fun (i,v) (i',v') -> i=i' && (value_eq strict v v')) l l' && value_eq strict v v' - | (V_record t l, V_record t' l') -> - t = t' && - listEqualBy (id_value_eq strict) l l' - | (V_ctor i t ckind v, V_ctor i' t' ckind' v') -> t = t' && ckind=ckind' && id_value_eq strict (i, v) (i', v') - | (V_ctor _ _ (C_Enum i) _,V_lit (L_aux (L_num j) _)) -> i = (natFromInteger j) - | (V_lit (L_aux (L_num j) _), V_ctor _ _ (C_Enum i) _) -> i = (natFromInteger j) - | (V_unknown,V_unknown) -> true - | (V_unknown,_) -> if strict then false else true - | (_,V_unknown) -> if strict then false else true - | (V_track v1 ts1, V_track v2 ts2) -> - if strict - then value_eq strict v1 v2 && ts1 = ts2 - else value_eq strict v1 v2 - | (V_track v _, v2) -> if strict then false else value_eq strict v v2 - | (v,V_track v2 _) -> if strict then false else value_eq strict v v2 - | (_, _) -> false - end -let {isabelle;hol} id_value_eq _ x y = unsafe_structural_equality x y -let {isabelle;hol} value_eq _ x y = unsafe_structural_equality x y - -let {coq;ocaml} value_ineq n1 n2 = not (value_eq false n1 n2) -let {isabelle;hol} value_ineq = unsafe_structural_inequality - -instance (Eq value) - let (=) = value_eq false - let (<>) = value_ineq -end - -let reg_start_pos reg = - match reg with - | Form_Reg _ (Just(typ,_,_,_,_)) _ -> - let start_from_vec targs = match targs with - | [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant s) _)) _;_;_;_] -> natFromInteger s - | [Typ_arg_aux (Typ_arg_nexp _) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant s) _)) _; Typ_arg_aux (Typ_arg_order Odec) _; _] -> (natFromInteger s) - 1 - | [_; _; Typ_arg_aux (Typ_arg_order Oinc) _; _] -> 0 - | _ -> Assert_extra.failwith "vector type not well formed" - end in - let start_from_reg targs = match targs with - | [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_app (Id_aux (Id "vector") _) targs) _)) _] -> start_from_vec targs - | _ -> Assert_extra.failwith "register not of type vector" - end in - match typ with - | Typ_aux (Typ_app id targs) _ -> - if get_id id = "vector" then start_from_vec targs - else if get_id id = "register" then start_from_reg targs - else Assert_extra.failwith "register abbrev not register or vector" - | _ -> Assert_extra.failwith "register abbrev not register or vector" - end - | _ -> Assert_extra.failwith "reg_start_pos found unexpected sub reg, or reg without a type" -end - -let reg_size reg = - match reg with - | Form_Reg _ (Just(typ,_,_,_,_)) _ -> - let end_from_vec targs = match targs with - | [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant s) _)) _;_;_] -> natFromInteger s - | _ -> Assert_extra.failwith "register vector type not well formed" - end in - let end_from_reg targs = match targs with - | [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_app (Id_aux (Id "vector") _) targs) _)) _] -> end_from_vec targs - | _ -> Assert_extra.failwith "register does not contain vector" - end in - match typ with - | Typ_aux (Typ_app id targs) _ -> - if get_id id = "vector" then end_from_vec targs - else if get_id id = "register" then end_from_reg targs - else Assert_extra.failwith "register type is none of vector, register, or abbrev" - | _ -> Assert_extra.failwith "register type is none of vector, register, or abbrev" - end - | _ -> Assert_extra.failwith "reg_size given unexpected sub reg or reg without a type" -end - -(*Constant unit value, for use in interpreter *) -let unit_ty = Typ_aux (Typ_id (Id_aux (Id "unit") Unknown)) Unknown -let unitv = V_lit (L_aux L_unit Unknown) -let unit_e = E_aux (E_lit (L_aux L_unit Unknown)) (Unknown, val_annot unit_ty) - -(* Store for local memory of ref cells, string stores the name of the function the memory is being created for*) -type lmem = LMem of string * nat * map nat value * set nat - -(* Environment for bindings *) -type env = map string value -(* Environment for lexical bindings, nat is a counter to build new unique variables when necessary *) -type lenv = LEnv of nat * env - -let emem name = LMem name 1 Map.empty Set.empty -let eenv = LEnv 1 Map.empty - -let rec list_to_string sep format = function - | [] -> "" - | [i] -> format i - | i::ls -> (format i) ^ sep ^ list_to_string sep format ls -end - -let env_to_string (LEnv c env) = - "(LEnv " ^ show c ^ " [" ^ - (list_to_string ", " (fun (k,v) -> k ^ " -> " ^ (string_of_value v)) (Map_extra.toList env)) ^ - "])" - -instance (Show lenv) - let show env = env_to_string env -end - -let mem_to_string (LMem f c mem _) = - "(LMem " ^ f ^ " " ^ show c ^ - " [" ^ (list_to_string ", " (fun (k,v) -> show k ^ " -> " ^ (string_of_value v)) (Map_extra.toList mem)) ^ "])" - -instance (Show lmem) - let show mem = mem_to_string mem -end - -type sub_reg_map = map string index_range - -(*top_level is a tuple of - (function definitions environment, - all extracted instructions (where possible), - default direction - letbound and enum values, - register values, - Typedef union constructors, - sub register mappings, and register aliases) *) -type top_level = - | Env of map string (list (funcl tannot)) (*function definitions environment*) - * list instruction_form (* extracted instructions (where extractable) *) - * i_direction (*default direction*) - * env (*letbound and enum values*) - * env (*register values*) - * map string typ (*typedef union constructors *) - * map string sub_reg_map (*sub register mappings*) - * map string (alias_spec tannot) (*register aliases*) - * bool (* debug? *) - -type action = - | Read_reg of reg_form * maybe (nat * nat) - | Write_reg of reg_form * maybe (nat * nat) * value - | Read_mem of id * value * maybe (nat * nat) - | Read_mem_tagged of id * value * maybe (nat * nat) - | Write_mem of id * value * maybe (nat * nat) * value - | Write_ea of id * value - | Write_memv of id * value * value - | Excl_res of id - | Write_memv_tagged of id * value * value * value - | Barrier of id * value - | Footprint of id * value - | Nondet of list (exp tannot) * tag - | Call_extern of string * value - | Return of value - | Exit of (exp tannot) - (* For the error case of a failed assert, carries up an optional error message*) - | Fail of value - (* For stepper, no action needed. String is function called, value is parameter where applicable *) - | Step of l * maybe string * maybe value - -(* Inverted call stack, where the frame with a Top stack waits for an action to resolve and - all other frames for their inner stack *) -type stack = - | Top - | Hole_frame of id * exp tannot * top_level * lenv * lmem * stack (* Stack frame waiting for a value *) - | Thunk_frame of exp tannot * top_level * lenv * lmem * stack (* Paused stack frame *) - -(*Internal representation of outcomes from running the interpreter. - Actions request an external party to resolve a request *) -type outcome = - | Value of value - | Action of action * stack - | Error of l * string - -let string_of_id id' = - (match id' with - | Id_aux id _ -> - (match id with - | Id s -> s - | DeIid s -> s - end) - end) - -instance (Show id) - let show = string_of_id -end - -let string_of_kid kid' = - (match kid' with - | Kid_aux kid _ -> - (match kid with - | Var s -> s - end) - end) - -instance (Show kid) - let show = string_of_kid -end - -let string_of_reg_id (RI_aux (RI_id id ) _) = string_of_id id - -instance forall 'a. (Show reg_id 'a) - let show = string_of_reg_id -end - -let rec string_of_typ typ' = - (match typ' with - | Typ_aux typ _ -> - (match typ with - | Typ_wild -> "(Typ_wild)" - | Typ_id id -> "(Typ_id " ^ (string_of_id id) ^ ")" - | Typ_var kid -> "(Typ_var " ^ (string_of_kid kid) ^ ")" - | Typ_fn typ1 typ2 eff -> "(Typ_fn _ _ _)" - | Typ_tup typs -> "(Typ_tup [" ^ String.concat "; " (List.map string_of_typ typs) ^ "])" - | Typ_app id args -> "(Typ_app " ^ string_of_id id ^ " _)" - end) - end) - -instance (Show typ) - let show = string_of_typ -end - -let rec string_of_lexp l' = - (match l' with - | LEXP_aux l _ -> - (match l with - | LEXP_id id -> "(LEXP_id " ^ string_of_id id ^ ")" - | LEXP_memory id exps -> "(LEXP_memory " ^ string_of_id id ^ " _)" - | LEXP_cast typ id -> "(LEXP_cast " ^ string_of_typ typ ^ " " ^ string_of_id id ^ ")" - | LEXP_tup lexps -> "(LEXP_tup [" ^ String.concat "; " (List.map string_of_lexp lexps) ^ "])" - | LEXP_vector lexps exps -> "(LEXP_vector _ _)" - | LEXP_vector_range lexp exp1 exp2 -> "(LEXP_vector_range _ _ _)" - | LEXP_field lexp id -> "(LEXP_field " ^ string_of_lexp lexp ^ "." ^ string_of_id id ^ ")" - end) - end) - -instance forall 'a. (Show lexp 'a) - let show = string_of_lexp -end - -let string_of_lit l' = - (match l' with - | L_aux l _ -> - (match l with - | L_unit -> "()" - | L_zero -> "0" - | L_one -> "1" - | L_true -> "true" - | L_false -> "false" - | L_num n -> "0d" ^ (show n) - | L_hex s -> "0x" ^ s - | L_bin s -> "0b" ^ s - | L_undef -> "undef" - | L_string s -> "\"" ^ s ^ "\"" - end) - end) - -instance (Show lit) - let show = string_of_lit -end - -let string_of_order o' = - (match o' with - | Ord_aux o _ -> - (match o with - | Ord_var kid -> string_of_kid kid - | Ord_inc -> "inc" - | Ord_dec -> "dec" - end) - end) - -instance (Show order) - let show = string_of_order -end - -let rec string_of_exp e' = - (match e' with - | E_aux e _ -> - (match e with - | E_block exps -> "(E_block [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_nondet exps -> "(E_nondet [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_id id -> "(E_id \"" ^ string_of_id id ^ "\")" - | E_lit lit -> "(E_lit " ^ string_of_lit lit ^ ")" - | E_cast typ exp -> "(E_cast " ^ string_of_typ typ ^ " " ^ string_of_exp exp ^ ")" - | E_app id exps -> "(E_app " ^ string_of_id id ^ " [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_app_infix exp1 id exp2 -> "(E_app_infix " ^ string_of_exp exp1 ^ " " ^ string_of_id id ^ " " ^ string_of_exp exp2 ^ ")" - | E_tuple exps -> "(E_tuple [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_if cond thn els -> "(E_if " ^ (string_of_exp cond) ^ " ? " ^ (string_of_exp thn) ^ " : " ^ (string_of_exp els) ^ ")" - | E_for id from to_ by order exp -> "(E_for " ^ string_of_id id ^ " " ^ string_of_exp from ^ " " ^ string_of_exp to_ ^ " " ^ string_of_exp by ^ " " ^ string_of_order order ^ " " ^ string_of_exp exp ^ ")" - | E_vector exps -> "(E_vector [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_vector_access exp1 exp2 -> "(E_vector_access " ^ string_of_exp exp1 ^ " " ^ string_of_exp exp2 ^ ")" - | E_vector_subrange exp1 exp2 exp3 -> "(E_vector_subrange " ^ string_of_exp exp1 ^ " " ^ string_of_exp exp2 ^ " " ^ string_of_exp exp3 ^ ")" - | E_vector_update _ _ _ -> "(E_vector_update)" - | E_vector_update_subrange _ _ _ _ -> "(E_vector_update_subrange)" - | E_vector_append exp1 exp2 -> "(E_vector_append " ^ string_of_exp exp1 ^ " " ^ string_of_exp exp2 ^ ")" - | E_list exps -> "(E_list [" ^ String.concat "; " (List.map string_of_exp exps) ^ "])" - | E_cons exp1 exp2 -> "(E_cons " ^ string_of_exp exp1 ^ " :: " ^ string_of_exp exp2 ^ ")" - | E_record _ -> "(E_record)" - | E_record_update _ _ -> "(E_record_update)" - | E_field _ _ -> "(E_field)" - | E_case _ _ -> "(E_case)" - | E_let _ _ -> "(E_let)" - | E_assign lexp exp -> "(E_assign " ^ string_of_lexp lexp ^ " := " ^ string_of_exp exp ^ ")" - | E_sizeof _ -> "(E_sizeof _)" - | E_exit exp -> "(E_exit " ^ string_of_exp exp ^ ")" - | E_return exp -> "(E_return " ^ string_of_exp exp ^ ")" - | E_assert cond msg -> "(E_assert " ^ string_of_exp cond ^ " " ^ string_of_exp msg ^ ")" - | E_internal_cast _ _ -> "(E_internal_cast _ _)" - | E_internal_exp _ -> "(E_internal_exp _)" - | E_sizeof_internal _ -> "(E_size _)" - | E_internal_exp_user _ _ -> "(E_internal_exp_user _ _)" - | E_comment _ -> "(E_comment _)" - | E_comment_struc _ -> "(E_comment_struc _)" - | E_internal_let _ _ _ -> "(E_internal_let _ _ _)" - | E_internal_plet _ _ _ -> "(E_internal_plet _ _ _)" - | E_internal_return _ -> "(E_internal_return _)" - | E_internal_value value -> "(E_internal_value " ^ debug_print_value value ^ ")" - end) - end) - -instance forall 'a. (Show (exp 'a)) - let show = string_of_exp -end - -let string_of_alias_spec (AL_aux _as _) = - (match _as with - | AL_subreg reg_id id -> "(AL_subreg " ^ (show reg_id) ^ " " ^ (show id) ^ ")" - | AL_bit reg_id exp -> "(AL_bit " ^ (show reg_id) ^ " " ^ (show exp) ^ ")" - | AL_slice reg_id exp1 exp2 -> "(AL_slice " ^ (show reg_id) ^ " " ^ (show exp1) ^ " " ^ (show exp2) ^ ")" - | AL_concat reg_id1 reg_id2 -> "(AL_concat " ^ (show reg_id1) ^ " " ^ (show reg_id2) ^ ")" - end) - -instance forall 'a. (Show alias_spec 'a) - let show = string_of_alias_spec -end - -let string_of_quant_item (QI_aux qi _) = - (match qi with - | QI_id kinded_id -> "(QI_id _)" - | QI_const nc -> "(QI_const _)" - end) - -instance (Show quant_item) - let show = string_of_quant_item -end - -let string_of_typquant (TypQ_aux tq _) = - (match tq with - | TypQ_tq qis -> "(TypQ_tq [" ^ (String.concat "; " (List.map show qis)) ^ "]" - | TypQ_no_forall -> "TypQ_no_forall" - end) - -instance (Show typquant) - let show = string_of_typquant -end - -let string_of_typschm (TypSchm_aux (TypSchm_ts typquant typ) _) = - "(TypSchm " ^ (show typquant) ^ " " ^ (show typ) ^ ")" - -instance (Show typschm) - let show = string_of_typschm -end - -let rec string_of_pat (P_aux pat _) = - (match pat with - | P_lit lit -> "(P_lit " ^ show lit ^ ")" - | P_wild -> "P_wild" - | P_as pat' id -> "(P_as " ^ string_of_pat pat' ^ " " ^ show id ^ ")" - | P_typ typ pat' -> "(P_typ" ^ show typ ^ " " ^ string_of_pat pat' ^ ")" - | P_id id -> "(P_id " ^ show id ^ ")" - | P_app id pats -> "(P_app " ^ show id ^ " [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" - | P_record _ _ -> "(P_record _ _)" - | P_vector pats -> "(P_vector [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" - | P_vector_concat pats -> "(P_vector_concat [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" - | P_tup pats -> "(P_tup [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" - | P_list pats -> "(P_list [" ^ String.concat "; " (List.map string_of_pat pats) ^ "])" - end) - -instance forall 'a. (Show pat 'a) - let show = string_of_pat -end - -let string_of_letbind (LB_aux lb _) = - (match lb with - | LB_val pat exp -> "(LB_val " ^ (show pat) ^ " " ^ (show exp) ^ ")" - end) - -instance forall 'a. (Show letbind 'a) - let show = string_of_letbind -end - -type interp_mode = <| eager_eval : bool; track_values : bool; track_lmem : bool; debug : bool; debug_indent : string |> - -let indent_mode mode = if mode.debug then <| mode with debug_indent = " " ^ mode.debug_indent |> else mode - -val debug_fun_enter : interp_mode -> string -> list string -> unit -let debug_fun_enter mode name args = - if mode.debug then - debug_print (mode.debug_indent ^ ":: " ^ name ^ " args: [" ^ (String.concat "; " args) ^ "]\n") - else - () - -val debug_fun_exit : forall 'a. Show 'a => interp_mode -> string -> 'a -> unit -let debug_fun_exit mode name retval = - if mode.debug then - debug_print (mode.debug_indent ^ "=> " ^ name ^ " returns: " ^ (show retval) ^ "\n") - else - () - -(* Evaluates global let binds and prepares the context for individual expression evaluation in the current model *) -val to_top_env : bool -> (i_direction -> outcome -> maybe value) -> defs tannot -> (maybe outcome * top_level) -val get_default_direction : top_level -> i_direction - -(* interprets the exp sequentially in the presence of a set of top level definitions and returns a value, a memory request, or other external action *) -val interp :interp_mode -> (i_direction -> outcome -> maybe value) -> defs tannot -> exp tannot -> (outcome * lmem * lenv) - -(* Takes a paused partially evaluated expression, puts the value into the environment, and runs again *) -val resume : interp_mode -> stack -> maybe value -> (outcome * lmem * lenv) - -(* Internal definitions to setup top_level *) -val to_fdefs : defs tannot -> map string (list (funcl tannot)) -let rec to_fdefs (Defs defs) = - match defs with - | [] -> Map.empty - | def::defs -> - match def with - | DEF_fundef f -> (match f with - | FD_aux (FD_function _ _ _ fcls) _ -> - match fcls with - | [] -> to_fdefs (Defs defs) - | (FCL_aux (FCL_Funcl name _) _)::_ -> - Map.insert (get_id name) fcls (to_fdefs (Defs defs)) end end) - | _ -> to_fdefs (Defs defs) end end - -val to_register_fields : defs tannot -> map string (map string index_range) -let rec to_register_fields (Defs defs) = - match defs with - | [ ] -> Map.empty - | def::defs -> - match def with - | DEF_type (TD_aux (TD_register id n1 n2 indexes) l') -> - Map.insert (get_id id) - (List.foldr (fun (a,b) imap -> Map.insert (get_id b) a imap) Map.empty indexes) - (to_register_fields (Defs defs)) - | _ -> to_register_fields (Defs defs) - end - end - -val to_registers : i_direction -> defs tannot -> env -let rec to_registers dd (Defs defs) = - match defs with - | [ ] -> Map.empty - | def::defs -> - match def with - | DEF_reg_dec (DEC_aux (DEC_reg typ id) (l,tannot)) -> - let dir = match tannot with - | Nothing -> dd - | Just(t, _, _, _,_) -> dd (*TODO, lets pull the direction out properly*) - end in - Map.insert (get_id id) (V_register(Form_Reg id tannot dir)) (to_registers dd (Defs defs)) - | DEF_reg_dec (DEC_aux (DEC_alias id aspec) (l,tannot)) -> - Map.insert (get_id id) (V_register_alias aspec tannot) (to_registers dd (Defs defs)) - | _ -> to_registers dd (Defs defs) - end - end - -val to_aliases : defs tannot -> map string (alias_spec tannot) -let rec to_aliases (Defs defs) = - match defs with - | [] -> Map.empty - | def::defs -> - match def with - | DEF_reg_dec (DEC_aux (DEC_alias id aspec) _) -> - Map.insert (get_id id) aspec (to_aliases (Defs defs)) - | DEF_reg_dec (DEC_aux (DEC_typ_alias typ id aspec) _) -> - Map.insert (get_id id) aspec (to_aliases (Defs defs)) - | _ -> to_aliases (Defs defs) - end - end - -val to_data_constructors : defs tannot -> map string typ -let rec to_data_constructors (Defs defs) = - match defs with - | [] -> - (*Prime environment with built-in constructors*) - Map.insert "Some" (Typ_aux (Typ_var (Kid_aux (Var "a") Unknown)) Unknown) - (Map.insert "None" unit_t Map.empty) - | def :: defs -> - match def with - | DEF_type (TD_aux t _)-> - match t with - | TD_variant id _ tq tid_list _ -> - (List.foldr - (fun (Tu_aux t _) map -> - match t with - | (Tu_ty_id x y) -> Map.insert (get_id y) x map - | Tu_id x -> Map.insert (get_id x) unit_t map end) - (to_data_constructors (Defs defs))) tid_list - | _ -> to_data_constructors (Defs defs) end - | _ -> to_data_constructors (Defs defs) end - end - -(*Memory and environment helper functions*) -val env_from_list : list (id * value) -> env -let env_from_list ls = List.foldr (fun (id,v) env -> Map.insert (get_id id) v env) Map.empty ls - -val in_env :forall 'a. map string 'a -> string -> maybe 'a -let in_env env id = Map.lookup id env - -val in_lenv : lenv -> id -> value -let in_lenv (LEnv _ env) id = - match in_env env (get_id id) with - | Nothing -> V_unknown - | Just v -> v -end - -(*Prefer entries in the first when in conflict*) -val union_env : lenv -> lenv -> lenv -let union_env (LEnv i1 env1) (LEnv i2 env2) = - let l = if i1 < i2 then i2 else i1 in - LEnv l (Map.(union) env2 env1) - -val fresh_var : lenv -> (id * lenv) -let fresh_var (LEnv i env) = - let lenv = (LEnv (i+1) env) in - ((Id_aux (Id ((show i) ^ "var")) Interp_ast.Unknown), lenv) - -val add_to_env : (id * value) -> lenv -> lenv -let add_to_env (id, entry) (LEnv i env) = (LEnv i (Map.insert (get_id id) entry env)) - -val in_mem : lmem -> nat -> value -let in_mem (LMem _ _ m _) n = - Map_extra.find n m - (* Map.lookup n m *) - -val update_mem : bool -> lmem -> nat -> value -> lmem -let update_mem track (LMem owner c m s) loc value = - let m' = Map.delete loc m in - let m' = Map.insert loc value m' in - let s' = if track then Set.insert loc s else s in - LMem owner c m' s' - -val clear_updates : lmem -> lmem -let clear_updates (LMem owner c m _) = LMem owner c m Set.empty - -(*Value helper functions*) - -val is_lit_vector : lit -> bool -let is_lit_vector (L_aux l _) = - match l with - | L_bin _ -> true - | L_hex _ -> true - | _ -> false -end - -val litV_to_vec : lit -> i_direction -> value -let litV_to_vec (L_aux lit l) (dir: i_direction) = - match lit with - | L_hex s -> - let to_v b = V_lit (L_aux b l) in - let hexes = List.map to_v - (List.concat - (List.map - (fun s -> match s with - | #'0' -> [L_zero;L_zero;L_zero;L_zero] - | #'1' -> [L_zero;L_zero;L_zero;L_one ] - | #'2' -> [L_zero;L_zero;L_one ;L_zero] - | #'3' -> [L_zero;L_zero;L_one ;L_one ] - | #'4' -> [L_zero;L_one ;L_zero;L_zero] - | #'5' -> [L_zero;L_one ;L_zero;L_one ] - | #'6' -> [L_zero;L_one ;L_one ;L_zero] - | #'7' -> [L_zero;L_one ;L_one ;L_one ] - | #'8' -> [L_one ;L_zero;L_zero;L_zero] - | #'9' -> [L_one ;L_zero;L_zero;L_one ] - | #'A' -> [L_one ;L_zero;L_one ;L_zero] - | #'B' -> [L_one ;L_zero;L_one ;L_one ] - | #'C' -> [L_one ;L_one ;L_zero;L_zero] - | #'D' -> [L_one ;L_one ;L_zero;L_one ] - | #'E' -> [L_one ;L_one ;L_one ;L_zero] - | #'F' -> [L_one ;L_one ;L_one ;L_one ] - | #'a' -> [L_one ;L_zero;L_one ;L_zero] - | #'b' -> [L_one ;L_zero;L_one ;L_one ] - | #'c' -> [L_one ;L_one ;L_zero;L_zero] - | #'d' -> [L_one ;L_one ;L_zero;L_one ] - | #'e' -> [L_one ;L_one ;L_one ;L_zero] - | #'f' -> [L_one ;L_one ;L_one ;L_one ] - | _ -> Assert_extra.failwith "Lexer did not restrict to valid hex" end) - (String.toCharList s))) in - V_vector (if is_inc(dir) then 0 else ((List.length hexes) - 1)) dir hexes - | L_bin s -> - let bits = List.map - (fun s -> match s with - | #'0' -> (V_lit (L_aux L_zero l)) - | #'1' -> (V_lit (L_aux L_one l)) - | _ -> Assert_extra.failwith "Lexer did not restrict to valid bin" - end) (String.toCharList s) in - V_vector (if is_inc(dir) then 0 else ((List.length bits) -1)) dir bits - | _ -> Assert_extra.failwith "litV predicate did not restrict to literal vectors" -end - -val list_nth : forall 'a . list 'a -> nat -> 'a -let list_nth l n = List_extra.nth l n - -val list_length : forall 'a . list 'a -> integer -let list_length l = integerFromNat (List.length l) - -val taint: value -> set reg_form -> value -let rec taint value regs = - if Set.null regs - then value - else match value with - | V_track value rs -> taint value (regs union rs) - | V_tuple vals -> V_tuple (List.map (fun v -> taint v regs) vals) - | _ -> V_track value regs -end - -val retaint: value -> value -> value -let retaint orig updated = - match orig with - | V_track _ rs -> taint updated rs - | _ -> updated -end - -val detaint: value -> value -let rec detaint value = - match value with - | V_track value _ -> detaint value - | v -> v -end - -(* the inner lambda is to make Isabelle happier about overlapping patterns *) -let rec binary_taint thunk = fun vall valr -> - match (vall,valr) with - | (V_track vl rl,V_track vr rr) -> taint (binary_taint thunk vl vr) (rl union rr) - | (V_track vl rl,vr) -> taint (binary_taint thunk vl vr) rl - | (vl,V_track vr rr) -> taint (binary_taint thunk vl vr) rr - | (vl,vr) -> thunk vl vr -end - -let rec merge_values v1 v2 = - if value_eq true v1 v2 - then v1 - else match (v1,v2) with - | (V_lit l, V_lit l') -> if lit_eq l l' then v1 else V_unknown - | (V_boxref n t, V_boxref m t') -> - (*Changes to memory handled by merge_mem*) - if n = m then v1 else V_unknown - | (V_tuple l, V_tuple l') -> - V_tuple (map2 merge_values l l') - | (V_list l, V_list l') -> - if (List.length l = List.length l') - then V_list (map2 merge_values l l') - else V_unknown - | (V_vector n b l, V_vector m b' l') -> - if b = b' && (List.length l = List.length l') - then V_vector n b (map2 merge_values l l') - else V_unknown - | (V_vector_sparse n o b l v, V_vector_sparse m p b' l' v') -> - if (n=m && o=p && b=b' && listEqualBy (fun (i,_) (i',_) -> i=i') l l') - then V_vector_sparse n o b (map2 (fun (i,v1) (i',v2) -> (i, merge_values v1 v2)) l l') (merge_values v v') - else V_unknown - | (V_record t l, V_record t' l') -> - (*assumes canonical order for fields in a record*) - if t = t' && List.length l = length l' - then V_record t (map2 (fun (i,v1) (_,v2) -> (i, merge_values v1 v2)) l l') - else V_unknown - | (V_ctor i t (C_Enum j) v, V_ctor i' t' (C_Enum j') v') -> - if i = i' then v1 else V_unknown - | (V_ctor _ _ (C_Enum i) _,V_lit (L_aux (L_num j) _)) -> if i = (natFromInteger j) then v1 else V_unknown - | (V_lit (L_aux (L_num j) _), V_ctor _ _ (C_Enum i) _) -> if i = (natFromInteger j) then v2 else V_unknown - | (V_ctor i t ckind v, V_ctor i' t' _ v') -> - if t = t' && i = i' - then (V_ctor i t ckind (merge_values v v')) - else V_unknown - | (V_unknown,V_unknown) -> V_unknown - | (V_track v1 ts1, V_track v2 ts2) -> - taint (merge_values v1 v2) (ts1 union ts2) - | (V_track v1 ts, v2) -> taint (merge_values v1 v2) ts - | (v1,V_track v2 ts) -> taint (merge_values v1 v2) ts - | (_, _) -> V_unknown -end - -val merge_lmems : lmem -> lmem -> lmem -let merge_lmems ((LMem owner1 c1 mem1 set1) as lmem1) ((LMem owner2 c2 mem2 set2) as lmem2) = - let diff1 = Set_extra.toList (set1 \ set2) in - let diff2 = Set_extra.toList (set2 \ set1) in - let inters = Set_extra.toList (set1 inter set2) in - let c = max c1 c2 in - let mem = LMem owner1 c (if c1 >= c2 then mem1 else mem2) Set.empty in - let diff_mem1 = - List.foldr - (fun i mem -> update_mem false mem i - (match Map.lookup i mem2 with - | Nothing -> V_unknown - | Just v -> merge_values (in_mem lmem1 i) v end)) mem diff1 in - let diff_mem2 = - List.foldr - (fun i mem -> update_mem false mem i - (match Map.lookup i mem1 with - | Nothing -> V_unknown - | Just v -> merge_values (in_mem lmem2 i) v end)) diff_mem1 diff2 in - List.foldr - (fun i mem -> update_mem false mem i (merge_values (in_mem lmem1 i) (in_mem lmem2 i))) - diff_mem2 inters - -let vector_length v = match (detaint v) with - | V_vector n inc vals -> List.length vals - | V_vector_sparse n m inc vals def -> m - | V_lit _ -> 1 - | _ -> 0 -end - -val access_vector : value -> nat -> value -let access_vector v n = - retaint v (match (detaint v) with - | V_unknown -> V_unknown - | V_lit (L_aux L_undef _) -> v - | V_lit (L_aux L_zero _) -> v - | V_lit (L_aux L_one _ ) -> v - | V_vector m dir vs -> - list_nth vs (if is_inc(dir) then (n - m) else (m - n)) - | V_vector_sparse _ _ _ vs d -> - match (List.lookup n vs) with - | Nothing -> d - | Just v -> v end - | _ -> Assert_extra.failwith ("access_vector given unexpected " ^ string_of_value v) - end ) - -val from_n_to_n :forall 'a. nat -> nat -> list 'a -> list 'a -let from_n_to_n from to_ ls = take (to_ - from + 1) (drop from ls) - -val slice_sparse_list : (nat -> nat -> bool) -> (nat -> nat) -> list (nat * value) -> nat -> nat -> ((list (nat * value)) * bool) -let rec slice_sparse_list compare update_n vals n1 n2 = - let sl = slice_sparse_list compare update_n in - if (n1 = n2) && (vals = []) - then ([],true) - else if (n1=n2) - then ([],false) - else match vals with - | [] -> ([],true) - | (i,v)::vals -> - if n1 = i - then let (rest,still_sparse) = (sl vals (update_n n1) n2) in ((i,v)::rest,still_sparse) - else if (compare n1 i) - then (sl vals (update_n n1) n2) - else let (rest,_) = (sl vals (update_n i) n2) in ((i,v)::rest,true) - end - -val slice_vector : value -> nat -> nat -> value -let slice_vector v n1 n2 = - retaint v (match detaint v with - | V_vector m dir vs -> - if is_inc(dir) - then V_vector n1 dir (from_n_to_n (n1 - m) (n2 - m) vs) - else V_vector n1 dir (from_n_to_n (m - n1) (m - n2) vs) - | V_vector_sparse m n dir vs d -> - let (slice, still_sparse) = - if is_inc(dir) - then slice_sparse_list (>) (fun i -> i + 1) vs n1 n2 - else slice_sparse_list (<) (fun i -> i - 1) vs n1 n2 in - if still_sparse && is_inc(dir) - then V_vector_sparse n1 (n2 - n1) dir slice d - else if is_inc(dir) then V_vector 0 dir (List.map snd slice) - else if still_sparse then V_vector_sparse n1 (n1 - n2) dir slice d - else V_vector n1 dir (List.map snd slice) - | _ -> Assert_extra.failwith ("slice_vector given unexpected " ^ string_of_value v) - end ) - -val update_field_list : list (id * value) -> env -> list (id * value) -let rec update_field_list base updates = - match base with - | [] -> [] - | (id,v)::bs -> match in_env updates (get_id id) with - | Just v -> (id,v)::(update_field_list bs updates) - | Nothing -> (id,v)::(update_field_list bs updates) end -end - -val fupdate_record : value -> value -> value -let fupdate_record base updates = - let fupdate_record_helper base updates = - (match (base,updates) with - | (V_record t bs,V_record _ us) -> V_record t (update_field_list bs (env_from_list us)) - | _ -> - Assert_extra.failwith ("fupdate_record given unexpected " ^ - string_of_value base ^ " and " ^ (string_of_value updates)) - end) in - binary_taint fupdate_record_helper base updates - -val fupdate_sparse : (nat -> nat -> bool) -> list (nat*value) -> nat -> value -> list (nat*value) -let rec fupdate_sparse comes_after vs n vexp = - match vs with - | [] -> [(n,vexp)] - | (i,v)::vs -> - if i = n then (i,vexp)::vs - else if (comes_after i n) then (n,vexp)::(i,v)::vs - else (i,v)::(fupdate_sparse comes_after vs n vexp) -end - -val fupdate_vec : value -> nat -> value -> value -let fupdate_vec v n vexp = - let tainted = binary_taint (fun v _ -> v) v vexp in - retaint tainted - (match detaint v with - | V_vector m dir vals -> - V_vector m dir (List.update vals (if is_inc(dir) then (n-m) else (m-n)) vexp) - | V_vector_sparse m o dir vals d -> - V_vector_sparse m o dir (fupdate_sparse (if is_inc(dir) then (>) else (<)) vals n vexp) d - | _ -> Assert_extra.failwith ("fupdate_vec given unexpected " ^ string_of_value v) - end) - -val replace_is : forall 'a. list 'a -> list 'a -> nat -> nat -> nat -> list 'a -let rec replace_is ls vs base start stop = - match (ls,vs) with - | ([],_) -> [] - | (ls,[]) -> ls - | (l::ls,v::vs) -> - if base >= start then - if start >= stop then v::ls - else v::(replace_is ls vs (base + 1) (start + 1) stop) - else l::(replace_is ls (v::vs) (base+1) start stop) - end - -val replace_sparse : (nat -> nat -> bool) -> list (nat * value) -> list (nat * value) -> list (nat * value) -let rec replace_sparse compare vals reps = - match (vals,reps) with - | ([],rs) -> rs - | (vs,[]) -> vs - | ((i1,v)::vs,(i2,r)::rs) -> - if i1 = i2 then (i2,r)::(replace_sparse compare vs rs) - else if (compare i1 i2) - then (i1,v)::(replace_sparse compare vs ((i2,r)::rs)) - else (i2,r)::(replace_sparse compare ((i1,v)::vs) rs) -end - -val fupdate_vector_slice : value -> value -> nat -> nat -> value -let fupdate_vector_slice vec replace start stop = - let fupdate_vec_help vec replace = - (match (vec,replace) with - | (V_vector m dir vals,V_vector r_m dir' reps) -> - V_vector m dir - (replace_is vals - (if dir=dir' then reps else (List.reverse reps)) - 0 (if is_inc(dir) then (start-m) else (m-start)) (if is_inc(dir) then (stop-m) else (m-stop))) - | (V_vector m dir vals, V_unknown) -> - V_vector m dir - (replace_is vals - (List.replicate (if is_inc(dir) then (stop-start) else (start-stop)) V_unknown) - 0 (if is_inc(dir) then (start-m) else (m-start)) (if is_inc(dir) then (stop-m) else (m-stop))) - | (V_vector_sparse m n dir vals d,V_vector _ _ reps) -> - let (_,repsi) = List.foldl (fun (i,rs) r -> ((if is_inc(dir) then i+1 else i-1), (i,r)::rs)) (start,[]) reps in - (V_vector_sparse m n dir (replace_sparse (if is_inc(dir) then (<) else (>)) vals (List.reverse repsi)) d) - | (V_vector_sparse m n dir vals d, V_unknown) -> - let (_,repsi) = List.foldl (fun (i,rs) r -> ((if is_inc(dir) then i+1 else i-1), (i,r)::rs)) (start,[]) - (List.replicate (if is_inc(dir) then (stop-start) else (start-stop)) V_unknown) in - (V_vector_sparse m n dir (replace_sparse (if is_inc(dir) then (<) else (>)) vals (List.reverse repsi)) d) - | (V_unknown,_) -> V_unknown - | _ -> Assert_extra.failwith ("fupdate vector slice given " ^ (string_of_value vec) - ^ " and " ^ (string_of_value replace)) - end) in - binary_taint fupdate_vec_help vec replace - -val update_vector_slice : bool -> value -> value -> nat -> nat -> lmem -> lmem -let update_vector_slice track vector value start stop mem = - match (detaint vector,detaint value) with - | ((V_boxref n t), v) -> - update_mem track mem n (fupdate_vector_slice (in_mem mem n) (retaint value v) start stop) - | ((V_vector m _ vs),(V_vector n _ vals)) -> - let (V_vector m' _ vs') = slice_vector vector start stop in - foldr2 (fun vbox v mem -> match vbox with - | V_boxref n t -> update_mem track mem n v end) - mem vs' vals - | ((V_vector m dir vs),(V_vector_sparse n o _ vals d)) -> - let (m',vs') = match slice_vector vector start stop with - | (V_vector m' _ vs') -> (m',vs') - | _ -> Assert_extra.failwith "slice_vector did not return vector" end in - let (_,mem) = foldr (fun vbox (i,mem) -> - match vbox with - | V_boxref n t -> - (if is_inc(dir) then i+1 else i-1, - update_mem track mem n (match List.lookup i vals with - | Nothing -> d - | Just v -> v end)) - | _ -> Assert_extra.failwith "Internal error: update_vector_slice not of boxes" - end) (m,mem) vs' in - mem - | ((V_vector m _ vs),v) -> - let (m',vs') = match slice_vector vector start stop with - | (V_vector m' _ vs') -> (m',vs') - | _ -> Assert_extra.failwith "slice vector didn't return vector" end in - List.foldr (fun vbox mem -> match vbox with - | V_boxref n t -> update_mem track mem n v - | _ -> Assert_extra.failwith "update_vector_slice not of boxes" end) - mem vs' - | _ -> Assert_extra.failwith ("update_vector_slice given unexpected " ^ string_of_value vector - ^ " and " ^ string_of_value value) -end - -let update_vector_start default_dir new_start expected_size v = - retaint v - (match detaint v with - | V_lit (L_aux L_zero _) -> V_vector new_start default_dir [v] - | V_lit (L_aux L_one _) -> V_vector new_start default_dir [v] - | V_vector m inc vs -> V_vector new_start inc vs (*Note, may need to shrink and check if still sparse *) - | V_vector_sparse m n dir vals d -> V_vector_sparse new_start n dir vals d - | V_unknown -> V_vector new_start default_dir (List.replicate expected_size V_unknown) - | V_lit (L_aux L_undef _) -> V_vector new_start default_dir (List.replicate expected_size v) - | _ -> Assert_extra.failwith ("update_vector_start given unexpected " ^ string_of_value v) - end) - -val in_ctors : list (id * typ) -> id -> maybe typ -let rec in_ctors ctors id = - match ctors with - | [] -> Nothing - | (cid,typ)::ctors -> if (get_id cid) = (get_id id) then Just typ else in_ctors ctors id -end - -(*Stack manipulation functions *) -(*Extends expression and context of 'top' stack frame *) -let add_to_top_frame e_builder stack = - match stack with - | Top -> Top - | Hole_frame id e t_level env mem stack -> - let (e',env') = (e_builder e env) in Hole_frame id e' t_level env' mem stack - | Thunk_frame e t_level env mem stack -> - let (e',env') = (e_builder e env) in Thunk_frame e' t_level env' mem stack - end - -(*Is this the innermost hole*) -let top_hole stack : bool = - match stack with - | Hole_frame _ (E_aux (E_id (Id_aux (Id "0") _)) _) _ _ _ Top -> true - | _ -> false -end - -let redex_id = id_of_string "0" -let mk_hole l annot t_level l_env l_mem = - Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem Top -let mk_thunk l annot t_level l_env l_mem = - Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,(intern_annot annot))) t_level l_env l_mem Top - -(*Converts a Hole_frame into a Thunk_frame, pushing to the top of the stack to insert the value at the innermost context *) -val add_answer_to_stack : stack -> value -> stack -let rec add_answer_to_stack stack v = - match stack with - | Top -> Top - | Hole_frame id e t_level env mem Top -> Thunk_frame e t_level (add_to_env (id,v) env) mem Top - | Thunk_frame e t_level env mem Top -> Thunk_frame e t_level env mem Top - | Hole_frame id e t_level env mem stack -> Hole_frame id e t_level env mem (add_answer_to_stack stack v) - | Thunk_frame e t_level env mem stack -> Thunk_frame e t_level env mem (add_answer_to_stack stack v) -end - -(*Throws away all but the environment and local memory of the top stack frame, putting given expression in this context *) -val set_in_context : stack -> exp tannot -> stack -let rec set_in_context stack e = - match stack with - | Top -> Top - | Hole_frame id oe t_level env mem Top -> Thunk_frame e t_level env mem Top - | Thunk_frame oe t_level env mem Top -> Thunk_frame e t_level env mem Top - | Hole_frame _ _ _ _ _ s -> set_in_context s e - | Thunk_frame _ _ _ _ s -> set_in_context s e -end - -let get_stack_state stack = - match stack with - | Top -> Assert_extra.failwith "Top reached in extracting stack state" - | Hole_frame id exp top_level lenv lmem stack -> (lenv,lmem) - | Thunk_frame exp top_level lenv lmem stack -> (lenv,lmem) -end - -let rec update_stack_state stack ((LMem name c mem _) as lmem) = - match stack with - | Top -> Top - | Hole_frame id oe t_level env (LMem _ _ _ s) Top -> - (match Map.lookup (0 : nat) mem with - | Nothing -> Thunk_frame oe t_level (add_to_env (id,V_unknown) env) (LMem name c mem s) Top - | Just v -> Thunk_frame oe t_level (add_to_env (id, v) env) (LMem name c (Map.delete (0 : nat) mem) s) Top end) - | Thunk_frame e t_level env _ Top -> Thunk_frame e t_level env lmem Top - | Hole_frame id e t_level env mem s -> Hole_frame id e t_level env mem (update_stack_state s lmem) - | Thunk_frame e t_level env mem s -> Thunk_frame e t_level env mem (update_stack_state s lmem) -end - -let rec clear_stack_state stack = - match stack with - | Top -> Top - | Hole_frame id e t_level env lmem Top -> Hole_frame id e t_level env (clear_updates lmem) Top - | Thunk_frame e t_level env lmem Top -> Thunk_frame e t_level env (clear_updates lmem) Top - | Hole_frame id e t_level env lmem s -> Hole_frame id e t_level env lmem (clear_stack_state s) - | Thunk_frame e t_level env lmem s -> Thunk_frame e t_level env lmem (clear_stack_state s) -end - -let rec remove_top_stack_frame stack = - match stack with - | Top -> Top - | Hole_frame _ _ _ _ _ Top -> Top - | Thunk_frame _ _ _ _ Top -> Top - | Hole_frame id e t_level env lmem stack -> Hole_frame id e t_level env lmem (remove_top_stack_frame stack) - | Thunk_frame e t_level env lmem stack -> Thunk_frame e t_level env lmem (remove_top_stack_frame stack) -end - -(*functions for converting in progress evaluation back into expression for building current continuation*) -let rec combine_typs ts = - match ts with - | [] -> mk_typ_var "fresh" - | [t] -> t - | t::ts -> - let t' = combine_typs ts in - match (t,t') with - | (_,Typ_aux (Typ_var _) _) -> t - | ((Typ_aux (Typ_app (Id_aux (Id "range") _) - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot1) _)) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top1) _)) _]) _), - (Typ_aux (Typ_app (Id_aux (Id "range") _) - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot2) _)) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top2) _)) _]) _)) -> - let (smallest,largest) = - if bot1 <= bot2 - then if top1 <= top2 then (bot1, top2) else (bot1, top1) - else if top1 <= top2 then (bot2, top2) else (bot2, top1) in - mk_typ_app "range" [Typ_arg_nexp (nconstant smallest); Typ_arg_nexp (nconstant largest)] - | ((Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a1) _)) _]) _), - (Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a2) _)) _]) _)) -> - if a1 = a2 - then t - else - let (smaller,larger) = if a1 < a2 then (a1,a2) else (a2,a1) in - mk_typ_app "range" [Typ_arg_nexp (nconstant smaller); Typ_arg_nexp (nconstant larger)] - | (Typ_aux (Typ_app (Id_aux (Id "range") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot) _)) _; - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top) _)) _]) _, - Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a) _)) _]) _) -> - if bot <= a && a <= top - then t - else if bot <= a && top <= a - then mk_typ_app "range" [Typ_arg_nexp (nconstant bot); Typ_arg_nexp (nconstant a)] - else mk_typ_app "range" [Typ_arg_nexp (nconstant a); Typ_arg_nexp (nconstant top)] - | (Typ_aux (Typ_app (Id_aux (Id "atom") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant a) _)) _]) _, - Typ_aux (Typ_app (Id_aux (Id "range") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant bot) _)) _; - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant top) _)) _]) _) -> - if bot <= a && a <= top - then t - else if bot <= a && top <= a - then mk_typ_app "range" [Typ_arg_nexp (nconstant bot); Typ_arg_nexp (nconstant a)] - else mk_typ_app "range" [Typ_arg_nexp (nconstant a); Typ_arg_nexp (nconstant top)] - | (Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b1) _)) _; - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r1) _)) _; - Typ_arg_aux (Typ_arg_order (Ord_aux o1 _)) _; - Typ_arg_aux (Typ_arg_typ t1) _]) _, - Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b2) _)) _; - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r2) _)) _; - Typ_arg_aux (Typ_arg_order (Ord_aux o2 _)) _; - Typ_arg_aux (Typ_arg_typ t2) _]) _) -> - let t = combine_typs [t1;t2] in - match (o1,o2) with - | (Ord_inc,Ord_inc) -> - let larger_start = if b1 < b2 then b2 else b1 in - let smaller_rise = if r1 < r2 then r1 else r2 in - mk_typ_app "vector" [Typ_arg_nexp (nconstant larger_start); Typ_arg_nexp (nconstant smaller_rise); - Typ_arg_order (Ord_aux o1 Unknown); Typ_arg_typ t] - | (Ord_dec,Ord_dec) -> - let smaller_start = if b1 < b2 then b1 else b2 in - let smaller_fall = if r1 < r2 then r2 else r2 in - mk_typ_app "vector" [Typ_arg_nexp (nconstant smaller_start); Typ_arg_nexp (nconstant smaller_fall); - Typ_arg_order (Ord_aux o1 Unknown); Typ_arg_typ t] - | _ -> mk_typ_var "fresh" - end - | _ -> t' - end - end - -let reg_to_t r = - match r with - | Form_Reg _ (Just (t,_,_,_,_)) _ -> t - | _ -> mk_typ_var "fresh" - end - -let rec val_typ v = - match v with - | V_boxref n t -> mk_typ_app "reg" [Typ_arg_typ t] - | V_lit (L_aux lit _) -> - match lit with - | L_unit -> mk_typ_id "unit" - | L_true -> mk_typ_id "bit" - | L_false -> mk_typ_id "bit" - | L_one -> mk_typ_id "bit" - | L_zero -> mk_typ_id "bit" - | L_string _ -> mk_typ_id "string" - | L_num n -> mk_typ_app "atom" [Typ_arg_nexp (nconstant n)] - | L_undef -> mk_typ_var "fresh" - | L_hex _ -> Assert_extra.failwith "literal hex not removed" - | L_bin _ -> Assert_extra.failwith "literal bin not removed" - end - | V_tuple vals -> mk_typ_tup (List.map val_typ vals) - | V_vector n dir vals -> - let ts = List.map val_typ vals in - let t = combine_typs ts in - mk_typ_app "vector" [Typ_arg_nexp (nconstant (integerFromNat n)); Typ_arg_nexp (nconstant (list_length vals)); - Typ_arg_order (Ord_aux (if is_inc dir then Ord_inc else Ord_dec) Unknown); - Typ_arg_typ t] - | V_vector_sparse n m dir vals d -> - let ts = List.map val_typ (d::(List.map snd vals)) in - let t = combine_typs ts in - mk_typ_app "vector" [Typ_arg_nexp (nconstant (integerFromNat n)); Typ_arg_nexp (nconstant (integerFromNat m)); - Typ_arg_order (Ord_aux (if is_inc dir then Ord_inc else Ord_dec) Unknown); - Typ_arg_typ t] - | V_record t ivals -> t - | V_list vals -> - let ts = List.map val_typ vals in - let t = combine_typs ts in - mk_typ_app "list" [Typ_arg_typ t] - | V_ctor id t _ vals -> t - | V_register reg -> reg_to_t reg - | V_track v _ -> val_typ v - | V_unknown -> mk_typ_var "fresh" - | V_register_alias _ _ -> mk_typ_var "fresh" - end - -let rec to_exp mode env v : (exp tannot * lenv) = - ((E_aux (E_internal_value v) (Interp_ast.Unknown, (val_annot (val_typ v)))), env) - -val env_to_let : interp_mode -> lenv -> (exp tannot) -> lenv -> ((exp tannot) * lenv) -let rec env_to_let_help mode env taint_env = match env with - | [] -> ([],taint_env) - | (i,v)::env -> - let t = (val_typ v) in - let tan = (val_annot t) in - let (e,taint_env) = to_exp mode taint_env v in - let (rest,taint_env) = env_to_let_help mode env taint_env in - ((((P_aux (P_id (id_of_string i)) (Unknown,tan)),e),t)::rest, taint_env) -end - -let env_to_let mode (LEnv _ env) (E_aux e annot) taint_env = - match env_to_let_help mode (Set_extra.toList (Map.toSet env)) taint_env with - | ([],taint_env) -> (E_aux e annot,taint_env) - | ([((p,e),t)],tain_env) -> - (E_aux (E_let (LB_aux (LB_val p e) (Unknown,(val_annot t))) e) annot,taint_env) - | (pts,taint_env) -> - let ts = List.map snd pts in - let pes = List.map fst pts in - let ps = List.map fst pes in - let es = List.map snd pes in - let t = mk_typ_tup ts in - let tan = val_annot t in - (E_aux (E_let (LB_aux (LB_val (P_aux (P_tup ps) (Unknown,tan)) - (E_aux (E_tuple es) (Unknown,tan))) (Unknown,tan)) - (E_aux e annot)) - annot, taint_env) -end - -let fix_up_nondet typ branches annot = - match typ with - | Typ_aux (Typ_id (Id_aux (Id "unit") _)) _ -> (branches, Nothing) - | _ -> ((List.map - (fun e -> E_aux (E_assign (LEXP_aux (LEXP_id redex_id) annot) e) annot) branches), Just "0") -end - -(* match_pattern returns a tuple of (pattern_matches? , pattern_passed_due_to_unknown?, env_of_pattern *) -val match_pattern : top_level -> pat tannot -> value -> bool * bool * lenv -let rec match_pattern t_level (P_aux p (_, annot)) value_whole = - let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - let (t,tag,cs) = match annot with - | Just(t,tag,cs,e,_) -> (t,tag,cs) - | Nothing -> (mk_typ_var "fresh",Tag_empty,[]) end in - let value = detaint value_whole in - let taint_pat v = binary_taint (fun v _ -> v) v value_whole in - match p with - | P_lit(lit) -> - if is_lit_vector lit then - let (n, inc, bits) = match litV_to_vec lit default_dir - with | V_vector n inc bits -> (n, inc, bits) - | _ -> Assert_extra.failwith "litV_to_vec failed" end in - match value with - | V_lit litv -> - if is_lit_vector litv then - let (n', inc', bits') = match litV_to_vec litv default_dir with - | V_vector n' inc' bits' -> (n', inc', bits') - | _ -> Assert_extra.failwith "litV_to_vec failed" end in - if n=n' && inc = inc' then (foldr2 (fun l r rest -> (l = r) && rest) true bits bits',false, eenv) - else (false,false,eenv) - else (false,false,eenv) - | V_vector n' inc' bits' -> - (foldr2 (fun l r rest -> (l=r) && rest) true bits bits',false,eenv) - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) end - else - match value with - | V_lit(litv) -> (lit = litv, false,eenv) - | V_vector _ _ [V_lit(litv)] -> (lit = litv,false,eenv) - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) - end - | P_wild -> (true,false,eenv) - | P_as pat id -> - let (matched_p,used_unknown,bounds) = match_pattern t_level pat value in - if matched_p then - (matched_p,used_unknown,(add_to_env (id,value_whole) bounds)) - else (false,false,eenv) - | P_typ typ pat -> match_pattern t_level pat value_whole - | P_id id -> (true, false, (LEnv 0 (Map.fromList [((get_id id),value_whole)]))) - | P_app (Id_aux id _) pats -> - match value with - | V_ctor (Id_aux cid _) t ckind (V_tuple vals) -> - if (id = cid && ((List.length pats) = (List.length vals))) - then foldr2 - (fun pat value (matched_p,used_unknown,bounds) -> - if matched_p then - let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat value) in - (matched_p, (used_unknown || used_unknown'), (union_env new_bounds bounds)) - else (false,false,eenv)) (true,false,eenv) pats vals - else (false,false,eenv) - | V_ctor (Id_aux cid _) t ckind (V_track (V_tuple vals) r) -> - if (id = cid && ((List.length pats) = (List.length vals))) - then foldr2 - (fun pat value (matched_p,used_unknown,bounds) -> - if matched_p then - let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint value r) in - (matched_p, (used_unknown || used_unknown'), (union_env new_bounds bounds)) - else (false,false,eenv)) (true,false,eenv) pats vals - else (false,false,eenv) - | V_ctor (Id_aux cid _) t ckind v -> - if id = cid - then (match (pats,detaint v) with - | ([],(V_lit (L_aux L_unit _))) -> (true,false,eenv) - | ([P_aux (P_lit (L_aux L_unit _)) _],(V_lit (L_aux L_unit _))) -> (true,false,eenv) - | ([p],_) -> match_pattern t_level p v - | _ -> (false,false,eenv) end) - else (false,false,eenv) - | V_lit (L_aux (L_num i) _) -> - match tag with - | Tag_enum _ -> - match Map.lookup (get_id (Id_aux id Unknown)) lets with - | Just(V_ctor _ t (C_Enum j) _) -> - if i = (integerFromNat j) then (true,false,eenv) - else (false,false,eenv) - | _ -> (false,false,eenv) end - | _ -> (false,false,eenv) end - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) end - | P_record fpats _ -> - match value with - | V_record t fvals -> - let fvals_env = env_from_list fvals in - List.foldr - (fun (FP_aux (FP_Fpat id pat) _) (matched_p,used_unknown,bounds) -> - if matched_p then - let (matched_p,used_unknown',new_bounds) = match in_env fvals_env (get_id id) with - | Nothing -> (false,false,eenv) - | Just v -> match_pattern t_level pat v end in - (matched_p, (used_unknown || used_unknown'), (union_env new_bounds bounds)) - else (false,false,eenv)) (true,false,eenv) fpats - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) - end - | P_vector pats -> - match value with - | V_vector n dir vals -> - if ((List.length vals) = (List.length pats)) - then foldr2 - (fun pat value (matched_p,used_unknown,bounds) -> - if matched_p then - let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat value) in - (matched_p, (used_unknown||used_unknown'), (union_env new_bounds bounds)) - else (false,false,eenv)) - (true,false,eenv) pats vals - else (false,false,eenv) - | V_vector_sparse n m dir vals d -> - if (m = (List.length pats)) - then let (_,matched_p,used_unknown,bounds) = - foldr - (fun pat (i,matched_p,used_unknown,bounds) -> - if matched_p - then let (matched_p,used_unknown',new_bounds) = - match_pattern t_level pat (match List.lookup i vals with - | Nothing -> d - | Just v -> (taint_pat v) end) in - ((if is_inc(dir) then i+1 else i-1), - matched_p,used_unknown||used_unknown',(union_env new_bounds bounds)) - else (i,false,false,eenv)) (n,true,false,eenv) pats in - (matched_p,used_unknown,bounds) - else (false,false,eenv) - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) - end - | P_vector_concat pats -> - match value with - | V_vector n dir vals -> - let (matched_p,used_unknown,bounds,remaining_vals) = vec_concat_match_top t_level pats vals dir in - (*List.foldl - (fun (matched_p,used_unknown,bounds,r_vals) (P_aux pat (l,Just(t,_,_,_))) -> - let (matched_p,used_unknown',bounds',matcheds,r_vals) = vec_concat_match_plev t_level pat r_vals inc l t in - (matched_p,(used_unknown || used_unknown'),(union_env bounds' bounds),r_vals)) (true,false,eenv,vals) pats in*) - if matched_p && ([] = remaining_vals) then (matched_p,used_unknown,bounds) else (false,false,eenv) - | V_unknown -> (true,true,eenv) - | _ -> (false,false, eenv) - end - | P_tup(pats) -> - match value with - | V_tuple(vals) -> - if ((List.length pats)= (List.length vals)) - then foldr2 - (fun pat v (matched_p,used_unknown,bounds) -> if matched_p then - let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat v) in - (matched_p,used_unknown ||used_unknown', (union_env new_bounds bounds)) - else (false,false,eenv)) - (true,false,eenv) pats vals - else (false,false,eenv) - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) - end - | P_list(pats) -> - match value with - | V_list(vals) -> - if ((List.length pats)= (List.length vals)) - then foldr2 - (fun pat v (matched_p,used_unknown,bounds) -> if matched_p then - let (matched_p,used_unknown',new_bounds) = match_pattern t_level pat (taint_pat v) in - (matched_p,used_unknown|| used_unknown', (union_env new_bounds bounds)) - else (false,false,eenv)) - (true,false,eenv) pats vals - else (false,false,eenv) - | V_unknown -> (true,true,eenv) - | _ -> (false,false,eenv) end - end - -and vec_concat_match_top t_level pats r_vals dir : ((*matched_p*) bool * (*used_unknown*) bool * lenv * (list value)) = - match pats with - | [] -> (true,false,eenv,r_vals) - | [(P_aux p (l,Just(t,_,_,_,_)))] -> - let (matched_p,used_unknown,bounds,_,r_vals) = vec_concat_match_plev t_level p r_vals dir l true t in - (matched_p,used_unknown,bounds,r_vals) - | (P_aux p (l,Just(t,_,_,_,_)))::pats -> - let (matched_p,used_unknown,bounds,matcheds,r_vals) = vec_concat_match_plev t_level p r_vals dir l false t in - if matched_p then - let (matched_p',used_unknown',bounds',r_vals) = vec_concat_match_top t_level pats r_vals dir in - (matched_p',(used_unknown || used_unknown'),union_env bounds' bounds, r_vals) - else (false,false,eenv,r_vals) - | _ -> Assert_extra.failwith "Type annotation illformed" -end - -and vec_concat_match_plev t_level pat r_vals dir l last_pat t = - match pat with - | P_lit (L_aux (L_bin bin_string) l') -> - let bin_chars = toCharList bin_string in - let binpats = List.map - (fun b -> P_aux (match b with - | #'0' -> P_lit (L_aux L_zero l') - | #'1' -> P_lit (L_aux L_one l') - | _ -> Assert_extra.failwith "bin not 0 or 1" end) (l',Nothing)) bin_chars in - vec_concat_match t_level binpats r_vals - | P_vector pats -> vec_concat_match t_level pats r_vals - | P_id id -> - (match t with - | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant i) _)) _;_;_]) _ -> - let wilds = List.genlist (fun _ -> P_aux P_wild (l,Nothing)) (natFromInteger i) in - let (matched_p,used_unknown,bounds,matcheds,r_vals) = vec_concat_match t_level wilds r_vals in - if matched_p - then (matched_p, used_unknown, - (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length matcheds) - 1)) dir matcheds)) - bounds), - matcheds,r_vals) - else (false,false,eenv,[],[]) - | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp nc) _;_;_]) _ -> - if last_pat - then - (true,false, - (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length r_vals) - 1)) dir r_vals)) eenv), - r_vals,[]) - else (false,false,eenv,[],[]) (*TODO use some constraint bounds here*) - | _ -> - if last_pat - then - (true,false, - (add_to_env (id,(V_vector (if is_inc(dir) then 0 else ((List.length r_vals) -1 )) dir r_vals)) eenv), - r_vals,[]) - else (false,false,eenv,[],[]) end) - | P_wild -> (match t with - | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant i) _)) _;_;_]) _ -> - let wilds = List.genlist (fun _ -> P_aux P_wild (l,Nothing)) (natFromInteger i) in - vec_concat_match t_level wilds r_vals - | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;Typ_arg_aux (Typ_arg_nexp nc) _;_;_]) _ -> - if last_pat - then - (true,false,eenv,r_vals,[]) - else (false,false,eenv,[],[]) (*TODO use some constraint bounds here*) - | _ -> - if last_pat - then - (true,false,eenv,r_vals,[]) - else (false,false,eenv,[],[]) end) - | P_as (P_aux pat (l',Just(t',_,_,_,_))) id -> - let (matched_p, used_unknown, bounds,matcheds,r_vals) = - vec_concat_match_plev t_level pat r_vals dir l last_pat t' in - if matched_p - then (matched_p, used_unknown, - (add_to_env (id,V_vector (if is_inc(dir) then 0 else (List.length matcheds)) dir matcheds) bounds), - matcheds,r_vals) - else (false,false,eenv,[],[]) - | P_typ _ (P_aux p (l',Just(t',_,_,_,_))) -> vec_concat_match_plev t_level p r_vals dir l last_pat t - | _ -> (false,false,eenv,[],[]) end - (*TODO Need to support indexed here, skipping intermediate numbers but consumming r_vals, and as *) - -and vec_concat_match t_level pats r_vals = - match pats with - | [] -> (true,false,eenv,[],r_vals) - | pat::pats -> match r_vals with - | [] -> (false,false,eenv,[],[]) - | r::r_vals -> - let (matched_p,used_unknown,new_bounds) = match_pattern t_level pat r in - if matched_p then - let (matched_p,used_unknown',bounds,matcheds,r_vals) = vec_concat_match t_level pats r_vals in - (matched_p, used_unknown||used_unknown',(union_env new_bounds bounds),r :: matcheds,r_vals) - else (false,false,eenv,[],[]) end - end - - -(* Returns all matches using Unknown until either there are no more matches or a pattern matches with no Unknowns used *) -val find_funcl : top_level -> list (funcl tannot) -> value -> list (lenv * bool * (exp tannot)) -let rec find_funcl t_level funcls value = - match funcls with - | [] -> [] - | (FCL_aux (FCL_Funcl id (Pat_aux (Pat_exp pat exp) _)) _)::funcls -> - let (is_matching,used_unknown,env) = match_pattern t_level pat value in - if (is_matching && used_unknown) - then (env,used_unknown,exp)::(find_funcl t_level funcls value) - else if is_matching then [(env,used_unknown,exp)] - else find_funcl t_level funcls value - end - -(*see above comment*) -val find_case : top_level -> list (pexp tannot) -> value -> list (lenv * bool * (exp tannot)) -let rec find_case t_level pexps value = - match pexps with - | [] -> [] - | (Pat_aux (Pat_exp p e) _)::pexps -> - let (is_matching,used_unknown,env) = match_pattern t_level p value in - if (is_matching && used_unknown) - then (env,used_unknown,e)::find_case t_level pexps value - else if is_matching then [(env,used_unknown,e)] - else find_case t_level pexps value - end - -val interp_main : interp_mode -> top_level -> lenv -> lmem -> (exp tannot) -> (outcome * lmem * lenv) -val exp_list : interp_mode -> top_level -> ((list (exp tannot)) -> lenv -> ((exp tannot) * lenv)) -> (list value -> value) -> lenv -> lmem -> list value -> list (exp tannot) -> (outcome * lmem * lenv) -val interp_lbind : interp_mode -> top_level -> lenv -> lmem -> (letbind tannot) -> ((outcome * lmem * lenv) * (maybe ((exp tannot) -> (letbind tannot)))) -val interp_alias_read : interp_mode -> top_level -> lenv -> lmem -> (alias_spec tannot) -> (outcome * lmem * lenv) - -let resolve_outcome to_match value_thunk action_thunk = - match to_match with - | (Value v,lm,le) -> value_thunk v lm le - | (Action action stack,lm,le) -> (action_thunk (Action action stack), lm,le) - | (Error l s,lm,le) -> (Error l s,lm,le) -end - -let string_of_action a = - (match a with - | Read_reg r _ -> "(Read_reg " ^ string_of_reg_form r ^ " _)" - | Write_reg r _ _ -> "(Write_reg " ^ string_of_reg_form r ^ " _ _)" - | Read_mem id v _ -> "(Read_mem " ^ string_of_id id ^ " " ^ debug_print_value v ^ " _)" - | Read_mem_tagged id v _ -> "(Read_mem_tagged " ^ string_of_id id ^ " " ^ debug_print_value v ^ " _)" - | Write_mem _ _ _ _ -> "(Write_mem _ _ _ _)" - | Write_ea id v -> "(Write_ea " ^ string_of_id id ^ " " ^ debug_print_value v ^ " _)" - | Write_memv _ _ _ -> "(Write_memv _ _ _)" - | Excl_res id -> "(Excl_res " ^ string_of_id id ^ ")" - | Write_memv_tagged _ _ _ _ -> "(Write_memv_tagged _ _ _ _)" - | Barrier id v -> "(Barrier " ^ string_of_id id ^ " " ^ debug_print_value v ^ ")" - | Footprint id v -> "(Footprint " ^ string_of_id id ^ " " ^ debug_print_value v ^ ")" - | Nondet exps _ -> "(Nondet [" ^ String.concat "; " (List.map string_of_exp exps) ^ "] _)" - | Call_extern s v -> "(Call_extern \"" ^ s ^ "\" " ^ debug_print_value v ^ ")" - | Return v -> "(Return " ^ debug_print_value v ^ ")" - | Exit exp -> "(Exit " ^ string_of_exp exp ^ ")" - | Fail v -> "(Fail " ^ debug_print_value v ^ ")" - | Step _ _ _ -> "(Step _ _ _)" - end) - -instance (Show action) - let show action = string_of_action action -end - -let string_of_outcome outcome = - (match outcome with - | Value v -> "(Value " ^ debug_print_value v ^ ")" - | Action a _ -> "(Action " ^ string_of_action a ^ " _)" - | Error _ s -> "(Error _ \"" ^ s ^ "\")" - end) - -instance (Show outcome) - let show outcome = string_of_outcome outcome -end - -let update_stack o fn = match o with - | Action act stack -> Action act (fn stack) - | _ -> o -end - -let debug_out fn value e tl lm le = - (Action (Step (get_exp_l e) fn value) (Thunk_frame e tl le lm Top),lm,le) - -let to_exps mode env vals = - List.foldr (fun v (es,env) -> let (e,env') = to_exp mode env v in (e::es, union_env env' env)) ([],env) vals - -let get_num v = match v with - | V_lit (L_aux (L_num n) _) -> n - | _ -> 0 end - -(*Interpret a list of expressions, tracking local state but evaluating in the same scope (i.e. not tracking env) *) -let rec __exp_list mode t_level build_e build_v l_env l_mem vals exps = - match exps with - | [ ] -> (Value (build_v vals), l_mem, l_env) - | e::exps -> - resolve_outcome (interp_main mode t_level l_env l_mem e) - (fun value lm le -> exp_list mode t_level build_e build_v l_env lm (vals++[value]) exps) - (fun a -> update_stack a (add_to_top_frame - (fun e env -> - let (es,env') = to_exps mode env vals in - let (e,env'') = build_e (es++(e::exps)) env' in - (e,env'')))) - end - -and exp_list mode t_level build_e build_v l_env l_mem vals exps = - let _ = debug_fun_enter mode "exp_list" [show vals; show exps] in - let retval = __exp_list (indent_mode mode) t_level build_e build_v l_env l_mem vals exps in - let _ = debug_fun_exit mode "exp_list" retval in - retval - -and __interp_main mode t_level l_env l_mem (E_aux exp (l,annot)) = - let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - let (typ,tag,ncs,effect,reffect) = match annot with - | Nothing -> - (mk_typ_var "fresh_v", Tag_empty,[],(Effect_aux (Effect_set []) Unknown),(Effect_aux (Effect_set []) Unknown)) - | Just(t, tag, ncs, ef,efr) -> (t,tag,ncs,ef,efr) end in - match exp with - | E_internal_value v -> (Value v, l_mem, l_env) - | E_lit lit -> - if is_lit_vector lit - then let is_inc = (match typ with - | Typ_aux (Typ_app (Id_aux (Id "vector") _) [_;_;Typ_arg_aux (Typ_arg_order (Ord_aux Ord_inc _)) _;_]) _ -> IInc | _ -> IDec end) in - (Value (litV_to_vec lit is_inc),l_mem,l_env) - else (Value (V_lit (match lit with - | L_aux L_false loc -> L_aux L_zero loc - | L_aux L_true loc -> L_aux L_one loc - | _ -> lit end)), l_mem,l_env) - | E_comment _ -> (Value unitv, l_mem,l_env) - | E_comment_struc _ -> (Value unitv, l_mem, l_env) - | E_cast ((Typ_aux typ _) as ctyp) exp -> - (*Cast is either a no-op, a signal to read a register, or a signal to change the start of a vector *) - resolve_outcome - (interp_main mode t_level l_env l_mem exp) - (fun v lm le -> - (* Potentially use cast to change vector start position *) - let conditional_update_vstart () = - match typ with - | Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp(Nexp_aux (Nexp_constant i) _)) _;_;_;_] -> - let i = natFromInteger i in - match (detaint v) with - | V_vector start dir vs -> - if start = i then (Value v,lm,le) else (Value (update_vector_start dir i 1 v),lm,le) - | _ -> (Value v,lm,le) end - | (Typ_var (Kid_aux (Var "length") _))-> - match (detaint v) with - | V_vector start dir vs -> - let i = (List.length vs) - 1 in - if start = i then (Value v,lm,le) else (Value (update_vector_start dir i 1 v),lm,le) - | _ -> (Value v,lm,le) end - | _ -> (Value v,lm,le) end in - (match (tag,detaint v) with - (*Cast is telling us to read a register*) - | (Tag_extern _, V_register regform) -> - (Action (Read_reg regform Nothing) (mk_hole l (val_annot (reg_to_t regform)) t_level le lm), lm,le) - (*Cast is changing vector start position, potentially*) - | (_,v) -> conditional_update_vstart () end)) - (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_cast ctyp e) (l,annot), env)))) - | E_id id -> - let name = get_id id in - match tag with - | Tag_empty -> - match in_lenv l_env id with - | V_boxref n t -> (Value (in_mem l_mem n),l_mem,l_env) - | value -> (Value value,l_mem,l_env) end - | Tag_global -> - match in_env lets name with - | Just(value) -> (Value value, l_mem,l_env) - | Nothing -> - (match in_env regs name with - | Just(value) -> (Value value, l_mem,l_env) - | Nothing -> (Error l ("Internal error: " ^ name ^ " unbound on Tag_global"),l_mem,l_env) end) end - | Tag_enum _ -> - match in_env lets name with - | Just(value) -> (Value value,l_mem,l_env) - | Nothing -> (Error l ("Internal error: " ^ name ^ " unbound on Tag_enum "), l_mem,l_env) - end - | Tag_extern _ -> (* update with id here when it's never just "register" *) - let regf = match in_lenv l_env id with (* Check for local treatment of a register as a value *) - | V_register regform -> regform - | _ -> - match in_env regs name with (* Register isn't a local value, so pull from global environment *) - | Just(V_register regform) -> regform - | _ -> Form_Reg id annot default_dir end end in - (Action (Read_reg regf Nothing) (mk_hole l annot t_level l_env l_mem), l_mem, l_env) - | Tag_alias -> - match in_env aliases name with - | Just aspec -> interp_alias_read mode t_level l_env l_mem aspec - | _ -> (Error l ("Internal error: alias not found"), l_mem,l_env) end - | _ -> - (Error l - ("Internal error: tag " ^ (string_of_tag tag) ^ " expected empty,enum,alias,or extern for " ^ name), - l_mem,l_env) - end - | E_if cond thn els -> - resolve_outcome - (interp_main mode t_level l_env l_mem cond) - (fun value_whole lm le -> - let value = detaint value_whole in - match (value,mode.eager_eval) with - (*TODO remove booleans here when fully removed elsewhere *) - | (V_lit(L_aux L_one _),true) -> interp_main mode t_level l_env lm thn - | (V_lit(L_aux L_one _),false) -> debug_out Nothing Nothing thn t_level lm l_env - | (V_vector _ _ [(V_lit(L_aux L_one _))],true) -> interp_main mode t_level l_env lm thn - | (V_vector _ _ [(V_lit(L_aux L_one _))],false) -> debug_out Nothing Nothing thn t_level lm l_env - | (V_unknown,_) -> - let (branches,maybe_id) = fix_up_nondet typ [thn;els] (l,annot) in - interp_main mode t_level l_env lm (E_aux (E_nondet branches) (l,non_det_annot annot maybe_id)) - | (_,true) -> interp_main mode t_level l_env lm els - | (_,false) -> debug_out Nothing Nothing els t_level lm l_env end) - (fun a -> update_stack a (add_to_top_frame (fun c env -> (E_aux (E_if c thn els) (l,annot), env)))) - | E_for id from to_ by ((Ord_aux o _) as order) exp -> - let is_inc = match o with | Ord_inc -> true | _ -> false end in - resolve_outcome - (interp_main mode t_level l_env l_mem from) - (fun from_val_whole lm le -> - let from_val = detaint from_val_whole in - let (from_e,env) = to_exp mode le from_val_whole in - match from_val with - | V_lit(L_aux(L_num from_num) fl) -> - resolve_outcome - (interp_main mode t_level env lm to_) - (fun to_val_whole lm le -> - let to_val = detaint to_val_whole in - let (to_e,env) = to_exp mode le to_val_whole in - match to_val with - | V_lit(L_aux (L_num to_num) tl) -> - resolve_outcome - (interp_main mode t_level env lm by) - (fun by_val_whole lm le -> - let by_val = detaint by_val_whole in - let (by_e,env) = to_exp mode le by_val_whole in - match by_val with - | V_lit (L_aux (L_num by_num) bl) -> - if ((is_inc && (from_num > to_num)) || (not(is_inc) && (from_num < to_num))) - then (Value(V_lit (L_aux L_unit l)),lm,le) - else - let (ftyp,ttyp,btyp) = (val_typ from_val,val_typ to_val,val_typ by_val) in - let augment_annot = (fl, val_annot (combine_typs [ftyp;ttyp])) in - let diff = L_aux (L_num (if is_inc then from_num+by_num else from_num - by_num)) fl in - let (augment_e,env) = match (from_val_whole,by_val_whole) with - | (V_lit _, V_lit _) -> ((E_aux (E_lit diff) augment_annot), env) - | (V_track _ rs, V_lit _) -> to_exp mode env (taint (V_lit diff) rs) - | (V_lit _, V_track _ rs) -> to_exp mode env (taint (V_lit diff) rs) - | (V_track _ r1, V_track _ r2) -> - (to_exp mode env (taint (V_lit diff) (r1 union r2))) - | _ -> Assert_extra.failwith "For loop from and by values not range" end in - let e = - (E_aux - (E_block - [(E_aux - (E_let - (LB_aux (LB_val (P_aux (P_id id) (fl,val_annot ftyp)) from_e) - (Unknown,val_annot ftyp)) - exp) (l,annot)); - (E_aux (E_for id augment_e to_e by_e order exp) (l,annot))]) - (l,annot)) in - if mode.eager_eval - then interp_main mode t_level env lm e - else debug_out Nothing Nothing e t_level lm env - | V_unknown -> - let e = - (E_aux - (E_let - (LB_aux - (LB_val (P_aux (P_id id) (fl, val_annot (val_typ from_val))) from_e) - (fl, val_annot (val_typ from_val))) - exp) (l,annot)) in - interp_main mode t_level env lm e - | _ -> (Error l "internal error: by must be a number",lm,le) end) - (fun a -> update_stack a - (add_to_top_frame (fun b env -> (E_aux (E_for id from_e to_e b order exp) (l,annot), env)))) - | V_unknown -> - let e = - (E_aux - (E_let (LB_aux - (LB_val (P_aux (P_id id) (fl, val_annot (val_typ from_val))) from_e) - (fl, val_annot (val_typ from_val))) exp) (l,annot)) in - interp_main mode t_level env lm e - | _ -> (Error l "internal error: to must be a number",lm,env) end) - (fun a -> update_stack a - (add_to_top_frame (fun t env -> - (E_aux (E_for id from_e t by order exp) (l,annot), env)))) - | V_unknown -> - let e = - (E_aux - (E_let (LB_aux (LB_val (P_aux (P_id id) (Unknown, val_annot (val_typ from_val))) from_e) - (Unknown, val_annot (val_typ from_val))) exp) (l,annot)) in - interp_main mode t_level env lm e - | _ -> (Error l "internal error: from must be a number",lm,le) end) - (fun a -> update_stack a - (add_to_top_frame (fun f env -> (E_aux (E_for id f to_ by order exp) (l,annot), env)))) - | E_case exp pats -> - resolve_outcome - (interp_main mode t_level l_env l_mem exp) - (fun v lm le -> - match find_case t_level pats v with - | [] -> (Error l ("No matching patterns in case for value " ^ (string_of_value v)),lm,le) - | [(env,_,exp)] -> - if mode.eager_eval - then interp_main mode t_level (union_env env l_env) lm exp - else debug_out Nothing Nothing exp t_level lm (union_env env l_env) - | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> - let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in - let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in - interp_main mode t_level taint_env lm (E_aux (E_nondet branches) (l,(non_det_annot annot maybe_id))) - end) - (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_case e pats) (l,annot), env)))) - | E_record(FES_aux (FES_Fexps fexps _) fes_annot) -> - let (fields,exps) = List.unzip (List.map (fun (FE_aux (FE_Fexp id exp) _) -> (id,exp)) fexps) in - exp_list mode t_level - (fun es env' -> - ((E_aux - (E_record - (FES_aux (FES_Fexps - (map2 (fun id exp -> (FE_aux (FE_Fexp id exp) (Unknown,Nothing))) fields es) - false) fes_annot)) - (l,annot)), env')) - (fun vs -> (V_record typ (List.zip fields vs))) l_env l_mem [] exps - | E_record_update exp (FES_aux (FES_Fexps fexps _) fes_annot) -> - resolve_outcome - (interp_main mode t_level l_env l_mem exp) - (fun rv lm le -> match rv with - | V_record t fvs -> - let (fields,exps) = List.unzip (List.map (fun (FE_aux (FE_Fexp id exp) _) -> (id,exp)) fexps) in - resolve_outcome - (exp_list mode t_level - (fun es env'-> - let (e,env'') = (to_exp mode env' rv) in - ((E_aux (E_record_update e - (FES_aux (FES_Fexps - (map2 (fun id exp -> (FE_aux (FE_Fexp id exp) (Unknown,Nothing))) - fields es) false) fes_annot)) - (l,annot)), env'')) - (fun vs -> (V_record t (List.zip fields vs))) l_env l_mem [] exps) - (fun vs lm le -> (Value (fupdate_record rv vs), lm, le)) - (fun a -> a) (*Due to exp_list this won't happen, but we want to functionaly update on Value *) - | V_unknown -> (Value V_unknown, lm, le) - | _ -> (Error l "internal error: record update requires record",lm,le) end) - (fun a -> update_stack a - (add_to_top_frame - (fun e env -> (E_aux(E_record_update e (FES_aux(FES_Fexps fexps false) fes_annot)) (l,annot), env)))) - | E_list(exps) -> - exp_list mode t_level (fun exps env' -> (E_aux (E_list exps) (l,annot),env')) V_list l_env l_mem [] exps - | E_cons hd tl -> - resolve_outcome - (interp_main mode t_level l_env l_mem hd) - (fun hdv lm le -> - resolve_outcome - (interp_main mode t_level l_env lm tl) - (fun tlv lm le -> match detaint tlv with - | V_list t -> (Value (retaint tlv (V_list (hdv::t))),lm,le) - | V_unknown -> (Value (retaint tlv V_unknown),lm,le) - | _ -> (Error l ("Internal error '::' of non-list value " ^ (string_of_value tlv)),lm,le) end) - (fun a -> update_stack a - (add_to_top_frame - (fun t env -> let (hde,env') = to_exp mode env hdv in (E_aux (E_cons hde t) (l,annot),env'))))) - (fun a -> update_stack a (add_to_top_frame (fun h env -> (E_aux (E_cons h tl) (l,annot), env)))) - | E_field exp id -> - resolve_outcome - (interp_main mode t_level l_env l_mem exp) - (fun value_whole lm le -> - match detaint value_whole with - | V_record t fexps -> - (match in_env (env_from_list fexps) (get_id id) with - | Just v -> (Value (retaint value_whole v),lm,l_env) - | Nothing -> (Error l "Internal_error: Field not found in record",lm,le) end) - | V_register ((Form_Reg _ annot _) as reg_form) -> - let id' = match annot with - | Just((Typ_aux (Typ_id (Id_aux (Id id') _)) _),_,_,_,_) -> id' - | _ -> Assert_extra.failwith "annotation not well formed for field access" - end in - (match in_env subregs id' with - | Just(indexes) -> - (match in_env indexes (get_id id) with - | Just ir -> - let sub_reg = Form_SubReg id reg_form ir in - (Action (Read_reg sub_reg Nothing) - (mk_hole l (val_annot (reg_to_t sub_reg)) t_level le lm),lm,le) - | _ -> (Error l "Internal error: unrecognized read, no id",lm,le) end) - | Nothing -> (Error l "Internal error: subregs indexes not found", lm, le) end) - | V_unknown -> (Value (retaint value_whole V_unknown),lm,l_env) - | _ -> - (Error l ("Internal error: neither register nor record at field access " - ^ (string_of_value value_whole)),lm,le) end) - (fun a -> - match (exp,a) with - | (E_aux _ (l,Just(_,Tag_extern _,_,_,_)), - (Action (Read_reg ((Form_Reg _ (Just((Typ_aux (Typ_id (Id_aux (Id id') _)) _),_,_,_,_)) _) as regf) Nothing) s)) -> - match in_env subregs id' with - | Just(indexes) -> - (match in_env indexes (get_id id) with - | Just ir -> - (Action (Read_reg (Form_SubReg id regf ir) Nothing) s) - | _ -> Error l "Internal error, unrecognized read, no id" - end) - | Nothing -> Error l "Internal error, unrecognized read, no reg" end - | _ -> update_stack a (add_to_top_frame (fun e env -> (E_aux(E_field e id) (l,annot),env))) end) - | E_vector_access vec i -> - resolve_outcome - (interp_main mode t_level l_env l_mem vec) - (fun vvec lm le -> - resolve_outcome - (interp_main mode t_level l_env lm i) - (fun iv lm le -> - (match detaint iv with - | V_unknown -> (Value iv,lm,le) - | V_lit (L_aux (L_num n) ln) -> - let n = natFromInteger n in - let v_access vvec num = - (match (detaint vvec, detaint num) with - | (V_vector _ _ _,V_lit _) -> Value (access_vector vvec n) - | (V_vector_sparse _ _ _ _ _,V_lit _) -> Value (access_vector vvec n) - | (V_register reg, V_lit _) -> - Action (Read_reg reg (Just (n,n))) (mk_hole l annot t_level l_env lm) - | (V_unknown,_) -> Value V_unknown - | _ -> Assert_extra.failwith - ("Vector access error: " ^ (string_of_value vvec) ^ "[" ^ (show n) ^ "]") - end) - in - (v_access (retaint iv vvec) iv,lm,le) - | _ -> (Error l "Vector access not given a number for index",lm,l_env) - end)) - (fun a -> update_stack a (add_to_top_frame(fun i' env -> - let (vec_e, env') = to_exp mode env vvec in - (E_aux (E_vector_access vec_e i') (l,annot), env'))))) - (fun a -> - update_stack a (add_to_top_frame (fun vec' env -> - (E_aux (E_vector_access vec' i) (l,annot), env)))) - | E_vector_subrange vec i1 i2 -> - resolve_outcome - (interp_main mode t_level l_env l_mem vec) - (fun vvec lm le -> - resolve_outcome - (interp_main mode t_level l_env lm i1) - (fun i1v lm le -> - resolve_outcome - (interp_main mode t_level l_env lm i2) - (fun i2v lm le -> - match detaint i1v with - | V_unknown -> (Value i1v,lm,le) - | V_lit (L_aux (L_num n1) nl1) -> - match detaint i2v with - | V_unknown -> (Value i2v,lm,le) - | V_lit (L_aux (L_num n2) nl2) -> - let slice = binary_taint (fun v1 v2 -> V_tuple[v1;v2]) i1v i2v in - let take_slice vvec = - let (n1,n2) = (natFromInteger n1,natFromInteger n2) in - (match detaint vvec with - | V_vector _ _ _ -> Value (slice_vector vvec n1 n2) - | V_vector_sparse _ _ _ _ _ -> Value (slice_vector vvec n1 n2) - | V_unknown -> - let inc = n1 < n2 in - Value (retaint vvec (V_vector n1 (if inc then IInc else IDec) - (List.replicate ((if inc then n1-n2 else n2-n1)+1) V_unknown))) - | V_register reg -> - Action (Read_reg reg (Just (n1,n2))) (mk_hole l annot t_level le lm) - | _ -> (Error l ("Vector slice of non-vector " ^ (string_of_value vvec))) end) in - ((take_slice (retaint slice vvec)), lm,le) - | _ -> (Error l "vector subrange did not receive a range value", l_mem, l_env) - end - | _ -> (Error l "vector subrange did not receive a range value", l_mem, l_env) - end) - (fun a -> update_stack a (add_to_top_frame (fun i2' env -> - let (vec_e, env') = to_exp mode env vvec in - let (i1_e, env'') = to_exp mode env' i1v in - (E_aux (E_vector_subrange vec_e i1_e i2') (l,annot), env''))))) - (fun a -> - update_stack a (add_to_top_frame (fun i1' env -> - let (vec_e, env') = to_exp mode env vvec in - (E_aux (E_vector_subrange vec_e i1' i2) (l,annot), env'))))) - (fun a -> - update_stack a (add_to_top_frame (fun vec' env -> - (E_aux (E_vector_subrange vec' i1 i2) (l,annot), env)))) - | E_vector_update vec i exp -> - resolve_outcome - (interp_main mode t_level l_env l_mem vec) - (fun vvec lm le -> - resolve_outcome - (interp_main mode t_level l_env lm i) - (fun vi lm le -> - resolve_outcome - (interp_main mode t_level l_env lm exp) - (fun vup lm le -> - (match (detaint vi) with - | V_lit (L_aux (L_num n1) ln1) -> - let fvup vi vvec = - (match vvec with - | V_vector _ _ _ -> fupdate_vec vvec (natFromInteger n1) vup - | V_vector_sparse _ _ _ _ _ -> fupdate_vec vvec (natFromInteger n1) vup - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith "Update of vector given non-vector" - end) - in - (Value (binary_taint fvup vi vvec),lm,le) - | V_unknown -> (Value vi,lm,le) - | _ -> Assert_extra.failwith "Update of vector requires number for access" - end)) - (fun a -> update_stack a (add_to_top_frame (fun exp' env -> - let (vec_e, env') = to_exp mode env vvec in - let (i_e, env'') = to_exp mode env' vi in - (E_aux (E_vector_update vec_e i_e exp') (l,annot), env''))))) - (fun a -> update_stack a (add_to_top_frame (fun i' env -> - let (vec_e, env') = to_exp mode env vvec in - (E_aux (E_vector_update vec_e i' exp) (l,annot), env'))))) - (fun a -> update_stack a (add_to_top_frame (fun vec' env -> - (E_aux (E_vector_update vec' i exp) (l,annot), env)))) - | E_vector_update_subrange vec i1 i2 exp -> - resolve_outcome - (interp_main mode t_level l_env l_mem vec) - (fun vvec lm le -> - resolve_outcome - (interp_main mode t_level l_env lm i1) - (fun vi1 lm le -> - resolve_outcome - (interp_main mode t_level l_env lm i2) - (fun vi2 lm le -> - resolve_outcome - (interp_main mode t_level l_env lm exp) - (fun v_rep lm le -> - (match detaint vi1 with - | V_unknown -> (Value vi1,lm,le) - | V_lit (L_aux (L_num n1) ln1) -> - (match detaint vi2 with - | V_unknown -> (Value vi2,lm,le) - | V_lit (L_aux (L_num n2) ln2) -> - let slice = binary_taint (fun v1 v2 -> V_tuple[v1;v2]) vi1 vi2 in - let fup_v_slice v1 vvec = - (match vvec with - | V_vector _ _ _ -> - fupdate_vector_slice vvec v_rep (natFromInteger n1) (natFromInteger n2) - | V_vector_sparse _ _ _ _ _ -> - fupdate_vector_slice vvec v_rep (natFromInteger n1) (natFromInteger n2) - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith "Vector update requires vector" - end) in - (Value (binary_taint fup_v_slice slice vvec),lm,le) - | _ -> Assert_extra.failwith "vector update requires number" - end) - | _ -> Assert_extra.failwith "vector update requires number" - end)) - (fun a -> update_stack a (add_to_top_frame (fun exp' env -> - let (vec_e, env') = to_exp mode env vvec in - let (i1_e, env'') = to_exp mode env' vi1 in - let (i2_e, env''') = to_exp mode env'' vi1 in - (E_aux (E_vector_update_subrange vec_e i1_e i2_e exp') (l,annot), env'''))))) - (fun a -> update_stack a (add_to_top_frame (fun i2' env -> - let (vec_e, env') = to_exp mode env vvec in - let (i1_e, env'') = to_exp mode env' vi1 in - (E_aux (E_vector_update_subrange vec_e i1_e i2' exp) (l,annot), env''))))) - (fun a -> update_stack a (add_to_top_frame (fun i1' env -> - let (vec_e, env') = to_exp mode env vvec in - (E_aux (E_vector_update_subrange vec_e i1' i2 exp) (l,annot), env'))))) - (fun a -> update_stack a (add_to_top_frame (fun vec' env -> - (E_aux (E_vector_update_subrange vec' i1 i2 exp) (l,annot), env)))) - | E_vector_append e1 e2 -> - resolve_outcome - (interp_main mode t_level l_env l_mem e1) - (fun v1 lm le -> - resolve_outcome - (interp_main mode t_level l_env lm e2) - (fun v2 lm le -> - (match detaint v1 with - | V_unknown -> (Value v1,lm,le) - | _ -> - let append v1 v2 = - (match (v1,v2) with - | (V_vector _ dir vals1, V_vector _ _ vals2) -> - let vals = vals1++vals2 in - let len = List.length vals in - if is_inc(dir) - then V_vector 0 dir vals - else V_vector (len-1) dir vals - | (V_vector m dir vals1, V_vector_sparse _ len _ vals2 d) -> - let original_len = List.length vals1 in - let (_,sparse_vals) = List.foldr (fun v (i,vals) -> (i+1,(i,v)::vals)) (m,[]) vals1 in - let sparse_update = List.map (fun (i,v) -> (i+m+original_len,v)) vals2 in - V_vector_sparse m (len+original_len) dir (sparse_vals ++ sparse_update) d - | (V_vector_sparse m len dir vals1 d, V_vector _ _ vals2) -> - let new_len = List.length vals2 in - let (_,sparse_vals) = List.foldr (fun v (i,vals) -> (i+1,(i,v)::vals)) (len,[]) vals2 in - V_vector_sparse m (len+new_len) dir (vals1++sparse_vals) d - | (V_vector_sparse m len dir vals1 d, V_vector_sparse _ new_len _ vals2 _) -> - let sparse_update = List.map (fun (i,v) -> (i+len,v)) vals2 in - V_vector_sparse m (len+new_len) dir (vals1 ++ sparse_update) d - | (V_unknown,_) -> V_unknown (*update to get length from type*) - | (_,V_unknown) -> V_unknown (*see above*) - | _ -> Assert_extra.failwith ("vector concat requires two vectors but given " - ^ (string_of_value v1) ^ " " ^ (string_of_value v2)) - end) - in - (Value (binary_taint append v1 v2),lm,le) - end)) - (fun a -> update_stack a (add_to_top_frame (fun e2' env -> - let (e1_e, env') = to_exp mode env v1 in - (E_aux (E_vector_append e1_e e2') (l,annot), env'))))) - (fun a -> update_stack a (add_to_top_frame (fun e1' env -> - (E_aux (E_vector_append e1' e2) (l,annot), env)))) - | E_tuple(exps) -> - exp_list mode t_level (fun exps env' -> (E_aux (E_tuple exps) (l,annot), env')) V_tuple l_env l_mem [] exps - | E_vector(exps) -> - let (is_inc,dir) = (match typ with - | Typ_aux (Typ_app (Id_aux (Id "vector") _) [ _; _; Typ_arg_aux (Typ_arg_order (Ord_aux Ord_inc _)) _; _]) _ -> (true,IInc) - | _ -> (false,IDec) end) in - let base = (if is_inc then 0 else (List.length exps) - 1) in - exp_list mode t_level - (fun exps env' -> (E_aux (E_vector exps) (l,annot),env')) - (fun vals -> V_vector base dir vals) l_env l_mem [] exps - | E_block exps -> interp_block mode t_level l_env l_env l_mem l annot exps - | E_nondet exps -> - (Action (Nondet exps tag) - (match tag with - | Tag_unknown (Just id) -> mk_hole l annot t_level l_env l_mem - | _ -> mk_thunk l annot t_level l_env l_mem end), - l_mem, l_env) - | E_app f args -> - (match (exp_list mode t_level - (fun es env -> (E_aux (E_app f es) (l,annot),env)) - (fun vs -> match vs with | [] -> V_lit (L_aux L_unit l) | [v] -> v | vs -> V_tuple vs end) - l_env l_mem [] args) with - | (Value v,lm,le) -> - let name = get_id f in - (match tag with - | Tag_global -> - (match Map.lookup name fdefs with - | Just(funcls) -> - (match find_funcl t_level funcls v with - | [] -> - (Error l ("No matching pattern for function " ^ name ^ - " on value " ^ (string_of_value v)),l_mem,l_env) - | [(env,_,exp)] -> - resolve_outcome - (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just v) exp t_level (emem name) env)) - (fun ret lm le -> (Value ret, l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) - t_level l_env l_mem stack))) - | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> - let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in - let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in - let exp = E_aux (E_nondet branches) (l,(non_det_annot annot maybe_id)) in - interp_main mode t_level taint_env lm exp - end) - | Nothing -> - (Error l ("Internal error: function with tag global unfound " ^ name),lm,le) end) - | Tag_empty -> - (match Map.lookup name fdefs with - | Just(funcls) -> - (match find_funcl t_level funcls v with - | [] -> - (Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value v)),l_mem,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just v) exp t_level (emem name) env)) - (fun ret lm le -> (Value ret, l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) - t_level l_env l_mem stack))) - | _ -> (Error l ("Internal error: multiple pattern matches found for " ^ name), l_mem, l_env) - end) - | Nothing -> - (Error l ("Internal error: function with local tag unfound " ^ name),lm,le) end) - | Tag_spec -> - (match Map.lookup name fdefs with - | Just(funcls) -> - (match find_funcl t_level funcls v with - | [] -> - (Error l ("No matching pattern for function " ^ name ^ " on value " ^ (string_of_value v)),l_mem,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just v) exp t_level (emem name) env)) - (fun ret lm le -> (Value ret, l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> - (Hole_frame redex_id - (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem stack))) - | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name), l_mem, l_env) - end) - | Nothing -> - (Error l (String.stringAppend "Specified function must be defined before executing " name),lm,le) end) - | Tag_ctor -> - (match Map.lookup name ctors with - | Just(_) -> (Value (V_ctor f typ C_Union v), lm, le) - | Nothing -> (Error l (String.stringAppend "Internal error: function with ctor tag unfound " name),lm,le) - end) - | Tag_extern opt_name -> - let effects = (match effect with | Effect_aux(Effect_set es) _ -> es | _ -> [] end) in - let name_ext = match opt_name with | Just s -> s | Nothing -> name end in - let mk_hole_frame act = (Action act (mk_hole l annot t_level le lm), lm, le) in - let mk_thunk_frame act = (Action act (mk_thunk l annot t_level le lm), lm, le) in - if has_rmem_effect effects - then mk_hole_frame (Read_mem (id_of_string name_ext) v Nothing) - else if has_rmemt_effect effects - then mk_hole_frame (Read_mem_tagged (id_of_string name_ext) v Nothing) - else if has_barr_effect effects - then mk_thunk_frame (Barrier (id_of_string name_ext) v) - else if has_depend_effect effects - then mk_thunk_frame (Footprint (id_of_string name_ext) v) - else if has_wmem_effect effects - then let (wv,v) = - match v with - | V_tuple [p;v] -> (v,p) - | V_tuple params_list -> - let reved = List.reverse params_list in - (List_extra.head reved,V_tuple (List.reverse (List_extra.tail reved))) - | _ -> Assert_extra.failwith ("Expected tuple found " ^ (string_of_value v)) end in - mk_hole_frame (Write_mem (id_of_string name_ext) v Nothing wv) - else if has_eamem_effect effects - then mk_thunk_frame (Write_ea (id_of_string name_ext) v) - else if has_exmem_effect effects - then mk_hole_frame (Excl_res (id_of_string name_ext)) - else if has_wmv_effect effects - then let (wv,v) = - match v with - | V_tuple [p;v] -> (v,p) - | V_tuple params_list -> - let reved= List.reverse params_list in - (List_extra.head reved,V_tuple (List.reverse (List_extra.tail reved))) - | _ -> (v,unitv) end in - mk_hole_frame (Write_memv (id_of_string name_ext) v wv) - else if has_wmvt_effect effects - then match v with - | V_tuple [addr; size; tag; data] -> - mk_hole_frame (Write_memv_tagged (id_of_string name_ext) (V_tuple([addr; size])) tag data) - | _ -> Assert_extra.failwith("wmvt: expected tuple of four elements") end - else mk_hole_frame (Call_extern name_ext v) - | _ -> - (Error l (String.stringAppend "Tag not empty, spec, ctor, or extern on function call " name),lm,le) end) - | out -> out end) - | E_app_infix lft op r -> - let op = match op with - | Id_aux (Id x) il -> Id_aux (DeIid x) il - | _ -> op - end in - let name = get_id op in - resolve_outcome - (interp_main mode t_level l_env l_mem lft) - (fun lv lm le -> - resolve_outcome - (interp_main mode t_level l_env lm r) - (fun rv lm le -> - match tag with - | Tag_global -> - (match Map.lookup name fdefs with - | Nothing -> (Error l ("Internal error: no function def for " ^ name),lm,le) - | Just (funcls) -> - (match find_funcl t_level funcls (V_tuple [lv;rv]) with - | [] -> (Error l ("No matching pattern for function " ^ name),lm,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) - (fun ret lm le -> (Value ret,l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> - (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) - t_level l_env l_mem stack))) - | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name),lm,le) - end)end) - | Tag_empty -> - (match Map.lookup name fdefs with - | Nothing -> (Error l ("Internal error: no function def for " ^ name),lm,le) - | Just (funcls) -> - (match find_funcl t_level funcls (V_tuple [lv;rv]) with - | [] -> (Error l ("No matching pattern for function " ^ name),lm,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) - (fun ret lm le -> (Value ret,l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,annot)) - t_level l_env l_mem stack))) - | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name),lm,le) - end)end) - | Tag_spec -> - (match Map.lookup name fdefs with - | Nothing -> (Error l ("Internal error: No function definition found for " ^ name),lm,le) - | Just (funcls) -> - (match find_funcl t_level funcls (V_tuple [lv;rv]) with - | [] -> (Error l ("No matching pattern for function " ^ name),lm,l_env) - | [(env,used_unknown,exp)] -> - resolve_outcome - (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just (V_tuple [lv;rv])) exp t_level (emem name) env)) - (fun ret lm le -> (Value ret,l_mem,l_env)) - (fun a -> update_stack a - (fun stack -> (Hole_frame redex_id - (E_aux (E_id redex_id) (l,(intern_annot annot))) - t_level l_env l_mem stack))) - | _ -> (Error l ("Internal error: multiple pattern matches for " ^ name), lm, le) - end)end) - | Tag_extern ext_name -> - let ext_name = match ext_name with Just s -> s | Nothing -> name end in - (Action (Call_extern ext_name (V_tuple [lv;rv])) - (Hole_frame redex_id - (E_aux (E_id redex_id) (l,intern_annot annot)) t_level le lm Top),lm,le) - | _ -> (Error l "Internal error: unexpected tag for app_infix", l_mem, l_env) end) - (fun a -> update_stack a - (add_to_top_frame - (fun r env -> let (el,env') = to_exp mode env lv in (E_aux (E_app_infix el op r) (l,annot), env'))))) - (fun a -> update_stack a (add_to_top_frame (fun lft env -> (E_aux (E_app_infix lft op r) (l,annot), env)))) - | E_exit exp -> - (Action (Exit exp) (mk_thunk l annot t_level l_env l_mem),l_mem, l_env) - | E_return exp -> - resolve_outcome - (interp_main mode t_level l_env l_mem exp) - (fun v lm le -> (Action (Return v) Top, l_mem, l_env)) - (fun a -> update_stack a (add_to_top_frame (fun e env -> (E_aux (E_return e) (l,annot), env)))) - | E_assert cond msg -> - resolve_outcome - (interp_main mode t_level l_env l_mem msg) - (fun v lm le -> - resolve_outcome - (interp_main mode t_level l_env lm cond) - (fun c lm le -> - (match detaint c with - | V_lit (L_aux L_one _) -> (Value unitv,lm,l_env) - | V_lit (L_aux L_true _) -> (Value unitv,lm,l_env) - | V_lit (L_aux L_zero _) -> (Action (Fail v) (mk_thunk l annot t_level l_env l_mem), lm,le) - | V_lit (L_aux L_false _) -> (Action (Fail v) (mk_thunk l annot t_level l_env l_mem), lm,le) - | V_unknown -> - let (branches,maybe_id) = - fix_up_nondet typ [unit_e; - E_aux (E_assert (E_aux (E_lit (L_aux L_zero l)) - (l,val_annot (mk_typ_id "bit"))) msg) (l,annot)] - (l,annot) in - interp_main mode t_level l_env lm (E_aux (E_nondet branches) (l,non_det_annot annot maybe_id)) - | _ -> (Error l ("assert given unexpected " ^ (string_of_value c)),l_mem,l_env) - end)) - (fun a -> update_stack a (add_to_top_frame (fun c env -> (E_aux (E_assert c msg) (l,annot), env))))) - (fun a -> update_stack a (add_to_top_frame (fun m env -> (E_aux (E_assert cond m) (l,annot), env)))) - | E_let (lbind : letbind tannot) exp -> - match (interp_letbind mode t_level l_env l_mem lbind) with - | ((Value v,lm,le),_) -> - if mode.eager_eval - then interp_main mode t_level le lm exp - else debug_out Nothing Nothing exp t_level lm le - | (((Action a s as o),lm,le),Just lbuild) -> - ((update_stack o (add_to_top_frame (fun e env -> (E_aux (E_let (lbuild e) exp) (l,annot), env)))),lm,le) - | (e,_) -> e end - | E_assign lexp exp -> - resolve_outcome - (interp_main mode t_level l_env l_mem exp) - (fun v lm le -> - (match create_write_message_or_update mode t_level v l_env lm true lexp with - | (outcome,Nothing,_) -> outcome - | (outcome,Just lexp_builder,Nothing) -> - resolve_outcome outcome - (fun v lm le -> (Value v,lm,le)) - (fun a -> - (match a with - | (Action (Write_reg regf range value) stack) -> a - | (Action (Write_mem id a_ range value) stack) -> a - | (Action (Write_memv _ _ _) stack) -> a - | (Action (Write_memv_tagged _ _ _ _) stack) -> a - | _ -> update_stack a (add_to_top_frame - (fun e env -> - let (ev,env') = (to_exp mode env v) in - let (lexp,env') = (lexp_builder e env') in - (E_aux (E_assign lexp ev) (l,annot),env'))) end)) - | (outcome,Just lexp_builder, Just v) -> - resolve_outcome outcome - (fun v lm le -> (Value v,lm,le)) - (fun a -> update_stack a (add_to_top_frame - (fun e env -> - let (ev,env') = to_exp mode env v in - let (lexp,env') = (lexp_builder e env') in - (E_aux (E_assign lexp ev) (l,annot),env')))) - end)) - (fun a -> update_stack a (add_to_top_frame (fun v env -> (E_aux (E_assign lexp v) (l,annot), env)))) - | _ -> (Error l "Internal expression escaped to interpreter", l_mem, l_env) - end - -and interp_main mode t_level l_env l_mem exp = - let _ = debug_fun_enter mode "interp_main" [show exp] in - let retval = __interp_main (indent_mode mode) t_level l_env l_mem exp in - let _ = debug_fun_exit mode "interp_main" retval in - retval - -(*TODO shrink location information on recursive calls *) -and __interp_block mode t_level init_env local_env local_mem l tannot exps = - match exps with - | [] -> (Value (V_lit (L_aux (L_unit) Unknown)), local_mem, init_env) - | [exp] -> - if mode.eager_eval - then interp_main mode t_level local_env local_mem exp - else debug_out Nothing Nothing exp t_level local_mem local_env - | exp:: exps -> - resolve_outcome (interp_main mode t_level local_env local_mem exp) - (fun _ lm le -> - if mode.eager_eval - then interp_block mode t_level init_env le lm l tannot exps - else debug_out Nothing Nothing (E_aux (E_block exps) (l,tannot)) t_level lm le) - (fun a -> update_stack a - (add_to_top_frame (fun e env-> (E_aux (E_block(e::exps)) (l,tannot), env)))) - end - -and interp_block mode t_level init_env local_env local_mem l tannot exps = - let _ = debug_fun_enter mode "interp_block" [show exps] in - let retval = __interp_block (indent_mode mode) t_level init_env local_env local_mem l tannot exps in - let _ = debug_fun_exit mode "interp_block" retval in - retval - -and __create_write_message_or_update mode t_level value l_env l_mem is_top_level - ((LEXP_aux lexp (l,annot)):lexp tannot) - : ((outcome * lmem * lenv) * maybe ((exp tannot) -> lenv -> ((lexp tannot) * lenv)) * maybe value) = - let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - let (typ,tag,ncs,ef,efr) = match annot with - | Nothing -> (mk_typ_var "fresh_v", Tag_empty, [], - (Effect_aux (Effect_set []) Unknown),(Effect_aux (Effect_set []) Unknown)) - | Just(t, tag, ncs, ef,efr) -> (t,tag,ncs,ef,efr) end in - let recenter_val (Typ_aux typ _) value = match typ with - | Typ_app (Id_aux (Id "reg") _) [Typ_arg_aux (Typ_arg_typ (Typ_aux (Typ_app (Id_aux (Id "vector") _) - [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant start) _)) _; Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant size) _)) _;_;_]) _)) _] -> - update_vector_start default_dir (natFromInteger start) (natFromInteger size) value - | _ -> value end in - match lexp with - | LEXP_id id -> - let name = get_id id in - match tag with - | Tag_intro -> - match detaint (in_lenv l_env id) with - | V_unknown -> - if is_top_level then - if name = "0" then - ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else - let (LMem owner c m s) = l_mem in - let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem c value, - (add_to_env (id,(V_boxref c typ)) l_env)),Nothing, Nothing) - else ((Error l ("Unknown local id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level - then - if name = "0" then - ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing,Nothing) - else - ((Error l ("Writes must be to reg values given " ^ (string_of_value v)),l_mem,l_env), - Nothing, Nothing) - else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) - end - | Tag_set -> - match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing, Nothing) - else ((Value v, l_mem, l_env),Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)), Nothing) - | V_unknown -> - if is_top_level then - if name = "0" then - ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else - let (LMem owner c m s) = l_mem in - let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem c value, - (add_to_env (id,(V_boxref c typ)) l_env)),Nothing,Nothing) - else ((Error l ("Unknown local id " ^ (get_id id)),l_mem,l_env),Nothing, Nothing) - | v -> - if is_top_level - then - if name = "0" then - ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else - ((Error l ("Writes must be to reg values given " ^ (string_of_value v)),l_mem,l_env), - Nothing, Nothing) - else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) - end - | Tag_empty -> - match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing, Nothing) - else ((Value v, l_mem, l_env),Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)), Nothing) - | V_unknown -> - if is_top_level then - if name = "0" then - ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else - let (LMem owner c m s) = l_mem in - let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem c value, - (add_to_env (id,(V_boxref c typ)) l_env)),Nothing, Nothing) - else ((Error l ("Unknown local id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level - then - if name = "0" then - ((Value (V_lit (L_aux L_unit l)), update_mem true l_mem 0 value, l_env), Nothing, Nothing) - else - ((Error l ("Writes must be to reg values given " ^ (string_of_value v)),l_mem,l_env), - Nothing, Nothing) - else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) - end - | Tag_global -> - (match in_env lets name with - | Just v -> - if is_top_level then ((Error l "Writes must be to reg or registers",l_mem,l_env),Nothing,Nothing) - else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_id id) (l,annot), env)), Nothing) - | Nothing -> - let regf = - match in_env regs name with (*pull the regform with the most specific type annotation from env *) - | Just(V_register regform) -> regform - | _ -> Assert_extra.failwith "Register not known in regenv" end in - let start_pos = reg_start_pos regf in - let reg_size = reg_size regf in - let request = - (Action (Write_reg regf Nothing - (if is_top_level then (update_vector_start default_dir start_pos reg_size value) else value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env) in - if is_top_level then (request,Nothing,Nothing) - else (request,Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)), Nothing) end) - | Tag_extern _ -> - let regf = - match in_env regs name with (*pull the regform with the most specific type annotation from env *) - | Just(V_register regform) -> regform - | _ -> Assert_extra.failwith "Register not known in regenv" end in - let start_pos = reg_start_pos regf in - let reg_size = reg_size regf in - let request = - (Action (Write_reg regf Nothing - (if is_top_level then (update_vector_start default_dir start_pos reg_size value) else value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env) in - if is_top_level then (request,Nothing,Nothing) - else (request,Just (fun e env -> (LEXP_aux (LEXP_id id) (l,annot), env)),Nothing) - | Tag_alias -> - let request = - (match in_env aliases name with - | Just (AL_aux aspec (l,_)) -> - (match aspec with - | AL_subreg (RI_aux (RI_id reg) (li, ((Just((Typ_aux (Typ_id (Id_aux (Id id) _)) _),_,_,_,_)) as annot'))) subreg -> - (match in_env subregs id with - | Just indexes -> - (match in_env indexes (get_id subreg) with - | Just ir -> - (Action - (Write_reg (Form_SubReg subreg (Form_Reg reg annot' default_dir) ir) Nothing - (update_vector_start default_dir (get_first_index_range ir) - (get_index_range_size ir) value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) - t_level l_env l_mem Top), l_mem, l_env) - | _ -> (Error l "Internal error, alias spec has unknown field", l_mem, l_env) end) - | _ -> - (Error l ("Internal error: alias spec has unknown register type " ^ id), l_mem, l_env) end) - | AL_bit (RI_aux (RI_id reg) (_,annot')) e -> - resolve_outcome (interp_main mode t_level l_env l_mem e) - (fun v le lm -> match v with - | V_lit (L_aux (L_num i) _) -> - let i = natFromInteger i in - (Action (Write_reg (Form_Reg reg annot' default_dir) (Just (i,i)) - (update_vector_start default_dir i 1 value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) - t_level l_env l_mem Top), l_mem, l_env) - | _ -> (Error l "Internal error: alias bit has non number", l_mem, l_env) end) - (fun a -> a) - | AL_slice (RI_aux (RI_id reg) (_,annot')) start stop -> - resolve_outcome (interp_main mode t_level l_env l_mem start) - (fun v lm le -> - match detaint v with - | V_lit (L_aux (L_num start) _) -> - (resolve_outcome (interp_main mode t_level l_env lm stop) - (fun v le lm -> - (match detaint v with - | V_lit (L_aux (L_num stop) _) -> - let (start,stop) = (natFromInteger start,natFromInteger stop) in - let size = if start < stop then stop - start +1 else start -stop +1 in - (Action (Write_reg (Form_Reg reg annot' default_dir) (Just (start,stop)) - (update_vector_start default_dir start size value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l, intern_annot annot)) - t_level l_env l_mem Top), - l_mem, l_env) - | _ -> (Error l "Alias slice has non number",l_mem, l_env) end)) - (fun a -> a)) - | _ -> (Error l "Alias slice has non number",l_mem,l_env) end) - (fun a -> a) - | AL_concat (RI_aux (RI_id reg1) (l1,annot1)) (RI_aux (RI_id reg2) annot2) -> - let val_typ (Typ_aux t _) = match t with - | Typ_app (Id_aux (Id "register") _) [Typ_arg_aux (Typ_arg_typ t) _] -> t - | _ -> Assert_extra.failwith "alias type ill formed" end in - let (t1,t2) = match (annot1,annot2) with - | (Just (t1,_,_,_,_), (_,(Just (t2,_,_,_,_)))) -> (val_typ t1,val_typ t2) - | _ -> Assert_extra.failwith "type annotations ill formed" end in - (match (t1,t2) with - | (Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b1) _)) _; - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r1) _)) _; _;_]) _, - Typ_aux (Typ_app (Id_aux (Id "vector") _) [Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant b2) _)) _; - Typ_arg_aux (Typ_arg_nexp (Nexp_aux (Nexp_constant r2) _)) _; _;_]) _) -> - (Action - (Write_reg (Form_Reg reg1 annot1 default_dir) Nothing - (slice_vector value (natFromInteger b1) (natFromInteger r1))) - (Thunk_frame - (E_aux (E_assign (LEXP_aux (LEXP_id reg2) annot2) - (fst (to_exp <| mode with track_values =false|> eenv - (slice_vector value (natFromInteger (r1+1)) (natFromInteger r2))))) - annot2) - t_level l_env l_mem Top), l_mem,l_env) - | _ -> (Error l "Internal error: alias vector types ill formed", l_mem, l_env) end) - | _ -> (Error l "Internal error: alias spec ill formed", l_mem, l_env) end) - | _ -> (Error l ("Internal error: alias not found for id " ^(get_id id)),l_mem,l_env) end) in - (request,Nothing,Nothing) - | _ -> - ((Error l ("Internal error: writing to id with tag other than extern, empty, or alias " ^ (get_id id)), - l_mem,l_env),Nothing,Nothing) - end - | LEXP_memory id exps -> - match (exp_list mode t_level (fun exps env -> (E_aux (E_tuple exps) (Unknown,Nothing),env)) - (fun vs -> - match vs with | [] -> V_lit (L_aux L_unit Unknown) | [v] -> v | vs -> V_tuple vs end) - l_env l_mem [] exps) with - | (Value v,lm,le) -> - (match tag with - | Tag_extern _ -> - let request = - let effects = (match ef with | Effect_aux(Effect_set es) _ -> es | _ -> [] end) in - let act = if has_wmem_effect effects then (Write_mem id v Nothing value) - else if has_wmv_effect effects then (Write_memv id v value) - else Assert_extra.failwith "LEXP_memory with neither wmem or wmv event" in - (Action act - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env lm Top), - lm,l_env) in - if is_top_level then (request,Nothing,Nothing) - else - (request, - Just (fun e env-> - let (parms,env) = (to_exps mode env (match v with | V_tuple vs -> vs | v -> [v] end)) in - (LEXP_aux (LEXP_memory id parms) (l,annot), env)), Nothing) - | Tag_global -> - let name = get_id id in - (match Map.lookup name fdefs with - | Just(funcls) -> - let new_vals = match v with - | V_tuple vs -> V_tuple (vs ++ [value]) - | V_lit (L_aux L_unit _) -> V_tuple [v;value] (*hmmm may be wrong in some code*) - | v -> V_tuple [v;value] end in - (match find_funcl t_level funcls new_vals with - | [] -> ((Error l ("No matching pattern for function " ^ name ^ - " on value " ^ (string_of_value new_vals)),l_mem,l_env),Nothing, Nothing) - | [(env,used_unknown,exp)] -> - (match (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just new_vals) exp t_level (emem name) env)) with - | (Value ret, _,_) -> ((Value ret, l_mem,l_env),Nothing, Nothing) - | (Action action stack,lm,le) -> - (((update_stack (Action action stack) - (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) - t_level l_env l_mem stack))), l_mem,l_env), Nothing, Nothing) - | (e,lm,le) -> ((e,lm,le),Nothing,Nothing) end) - | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> - let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in - let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in - (interp_main mode t_level taint_env lm (E_aux (E_nondet branches) - (l,non_det_annot annot maybe_id)), - Nothing, Nothing) - end) - | Nothing -> - ((Error l ("Internal error: function unfound " ^ name),lm,le),Nothing,Nothing) end) - | Tag_spec -> - let name = get_id id in - (match Map.lookup name fdefs with - | Just(funcls) -> - let new_vals = match v with - | V_tuple vs -> V_tuple (vs ++ [value]) - | V_lit (L_aux L_unit _) -> V_tuple [v;value] (*hmmm may be wrong in some code*) - | v -> V_tuple [v;value] end in - (match find_funcl t_level funcls new_vals with - | [] -> ((Error l ("No matching pattern for function " ^ name ^ - " on value " ^ (string_of_value new_vals)),l_mem,l_env),Nothing,Nothing) - | [(env,used_unknown,exp)] -> - (match (if mode.eager_eval - then (interp_main mode t_level env (emem name) exp) - else (debug_out (Just name) (Just new_vals) exp t_level (emem name) env)) with - | (Value ret, _,_) -> ((Value ret, l_mem,l_env),Nothing,Nothing) - | (Action action stack,lm,le) -> - (((update_stack (Action action stack) - (fun stack -> (Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) - t_level l_env l_mem stack))), l_mem,l_env), Nothing, Nothing) - | (e,lm,le) -> ((e,lm,le),Nothing,Nothing) end) - | multi_matches -> - let (lets,taint_env) = - List.foldr (fun (env,_,exp) (rst,taint_env) -> - let (e,t_e) = env_to_let mode env exp taint_env in (e::rst,t_e)) ([],l_env) multi_matches in - let (branches,maybe_id) = fix_up_nondet typ lets (l,annot) in - (interp_main mode t_level taint_env lm (E_aux (E_nondet branches) - (l,non_det_annot annot maybe_id)), - Nothing,Nothing) - end) - | Nothing -> - ((Error l ("Internal error: function unfound " ^ name),lm,le),Nothing,Nothing) end) - | _ -> ((Error l "Internal error: unexpected tag for memory or register write", lm,le),Nothing,Nothing) - end) - | (Action a s,lm, le) -> - ((Action a s,lm,le), - Just (fun (E_aux e _) env -> - (match e with | E_tuple es -> (LEXP_aux (LEXP_memory id es) (l,annot), env) - | _ -> Assert_extra.failwith "Lexp builder not well formed" end)), Nothing) - | e -> (e,Nothing,Nothing) end - | LEXP_cast typc id -> - let name = get_id id in - match tag with - | Tag_intro -> - match detaint (in_lenv l_env id) with - | V_unknown -> - if is_top_level - then begin - let (LMem owner c m s) = l_mem in - let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, - (add_to_env (id,(V_boxref c typ)) l_env)),Nothing, Nothing) - end - else ((Error l ("LEXP:cast1: Undefined id " ^ (get_id id)),l_mem,l_env),Nothing, Nothing) - | v -> - if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing, Nothing) - else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_cast typc id) (l,annot), env)), Nothing) - end - | Tag_set -> - match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing,Nothing) - else ((Value v, l_mem, l_env), - Just (fun e env -> (LEXP_aux (LEXP_cast typc id) (l,annot), env)), Nothing) - | V_unknown -> - if is_top_level - then begin - let (LMem owner c m s) = l_mem in - let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, - (add_to_env (id,(V_boxref c typ)) l_env)),Nothing,Nothing) - end - else ((Error l ("LEXP:cast2: Undefined id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing,Nothing) - else ((Value v,l_mem,l_env), - Just (fun e env -> (LEXP_aux(LEXP_cast typc id) (l,annot), env)),Nothing) - end - | Tag_empty -> - match detaint (in_lenv l_env id) with - | ((V_boxref n t) as v) -> - if is_top_level - then ((Value (V_lit (L_aux L_unit l)), - update_mem mode.track_lmem l_mem n (recenter_val t value), l_env),Nothing,Nothing) - else ((Value v, l_mem, l_env), - Just (fun e env -> (LEXP_aux (LEXP_cast typc id) (l,annot), env)), Nothing) - | V_unknown -> - if is_top_level - then begin - let (LMem owner c m s) = l_mem in - let l_mem = (LMem owner (c+1) m s) in - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem l_mem c value, - (add_to_env (id,(V_boxref c typ)) l_env)),Nothing,Nothing) - end - else ((Error l ("LEXP:cast3: Undefined id " ^ (get_id id)),l_mem,l_env),Nothing,Nothing) - | v -> - if is_top_level then ((Error l "Writes must be to reg values",l_mem,l_env),Nothing,Nothing) - else ((Value v,l_mem,l_env),Just (fun e env -> (LEXP_aux(LEXP_cast typc id) (l,annot), env)),Nothing) - end - | Tag_extern _ -> - let regf = - match in_env regs name with (*pull the regform with the most specific type annotation from env *) - | Just(V_register regform) -> regform - | _ -> Assert_extra.failwith "Register not known in regenv" end in - let start_pos = reg_start_pos regf in - let reg_size = reg_size regf in - let request = - (Action (Write_reg regf Nothing - (if is_top_level - then (update_vector_start default_dir start_pos reg_size value) - else value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env) in - if is_top_level then (request,Nothing,Nothing) - else (request,Just (fun e env -> (LEXP_aux (LEXP_cast typc id) (l,annot), env)),Nothing) - | _ -> - ((Error l ("Internal error: writing to id not extern or empty " ^(get_id id)),l_mem,l_env), - Nothing,Nothing) - end - | LEXP_tup ltups -> - match (ltups,value) with - | ([],_) -> - ((Error l "Internal error: found an empty tuple of assignments as an lexp", l_mem, l_env), Nothing,Nothing) - | ([le],V_tuple[v]) -> create_write_message_or_update mode t_level v l_env l_mem true le - | (le::ltups,V_tuple (v::vs)) -> - let new_v = V_tuple vs in - (match (create_write_message_or_update mode t_level v l_env l_mem true le) with - | ((Value v_whole,lm,le),Nothing,Nothing) -> - create_write_message_or_update mode t_level new_v le lm true (LEXP_aux (LEXP_tup ltups) (l,annot)) - | ((Action act stack,lm,le),Nothing,Nothing) -> - ((Action act stack,lm,le), Just (fun e env -> (LEXP_aux (LEXP_tup ltups) (l,annot),env)), Just new_v) - | ((Action act stack,lm,le), Just le_builder, Nothing) -> - ((Action act stack,lm,le), - Just (fun e env -> - let (lexp,env) = le_builder e env in - (LEXP_aux (LEXP_tup (lexp::ltups)) (l,annot),env)), Just value) - | ((Action act stack, lm,le), Just le_builder, Just v) -> - ((Action act stack, lm, le), - Just (fun e env -> - let (lexp,env) = le_builder e env in - (LEXP_aux (LEXP_tup (lexp::ltups)) (l,annot),env)), Just (V_tuple (v::vs))) - | ((Error l msg,lm,le),_,_) -> ((Error l msg,lm,le),Nothing,Nothing) - | _ -> - ((Error l "Internal error: Unexpected pattern match failure in LEXP_tup",l_mem,l_env),Nothing,Nothing) - end) - end - | LEXP_vector lexp exp -> - match (interp_main mode t_level l_env l_mem exp) with - | (Value i,lm,le) -> - (match detaint i with - | V_unknown -> ((Value i,lm,le),Nothing,Nothing) - | V_lit (L_aux (L_num n) ln) -> - let next_builder le_builder = - (fun e env -> - let (lexp,env) = le_builder e env in - let (ie,env) = to_exp mode env i in - (LEXP_aux (LEXP_vector lexp ie) (l,annot), env)) in - let n = natFromInteger n in - (match (create_write_message_or_update mode t_level value l_env lm false lexp) with - | ((Value v_whole,lm,le),maybe_builder,maybe_value) -> - let v = detaint v_whole in - let nth _ = detaint (access_vector v n) in - (match v with - | V_unknown -> ((Value v_whole,lm,le),Nothing,Nothing) - | V_boxref i _ -> - (match (in_mem lm i,is_top_level,maybe_builder) with - | ((V_vector _ _ _ as vec),true,_) -> - let new_vec = fupdate_vector_slice vec (V_vector 1 default_dir [value]) n n in - ((Value (V_lit (L_aux L_unit Unknown)), - update_mem mode.track_lmem lm i new_vec, l_env), Nothing,Nothing) - | ((V_track (V_vector _ _ _ as vec) r), true,_) -> - let new_vec = fupdate_vector_slice vec (V_vector 1 default_dir [value]) n n in - ((Value (V_lit (L_aux L_unit Unknown)), - update_mem mode.track_lmem lm i (taint new_vec r),l_env),Nothing,Nothing) - | ((V_vector _ _ _ as vec),false, Just lexp_builder) -> - ((Value (access_vector vec n), lm, l_env), Just (next_builder lexp_builder),Nothing) - | (v,_,_) -> - Assert_extra.failwith("no vector findable in set bit, found " ^ (string_of_value v)) - end ) - | V_vector inc m vs -> - (match (nth(),is_top_level,maybe_builder) with - | (V_register regform,true,_) -> - let start_pos = reg_start_pos regform in - let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) - (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env), - Nothing,Nothing) - | (V_register regform,false,Just lexp_builder) -> - let start_pos = reg_start_pos regform in - let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) - (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env), - Just (next_builder lexp_builder),maybe_value) - | (V_boxref n t,true,_) -> - ((Value (V_lit (L_aux L_unit Unknown)), update_mem mode.track_lmem lm n value, l_env), - Nothing,Nothing) - | (V_unknown,true,_) -> ((Value (V_lit (L_aux L_unit Unknown)), lm, l_env),Nothing,Nothing) - | (v,true,_) -> - ((Error l "Vector does not contain reg or register values",lm,l_env),Nothing,Nothing) - | ((V_boxref n t),false, Just lexp_builder) -> - ((Value (in_mem lm n),lm, l_env),Just (next_builder lexp_builder),Nothing) - | (v,false, Just lexp_builder) -> - ((Value v,lm,le), Just (next_builder lexp_builder),Nothing) - | _ -> Assert_extra.failwith "Vector assignment logic incomplete" - end) - | V_vector_sparse n m inc vs d -> - (match (nth(),is_top_level,maybe_builder) with - | (V_register regform,true,_) -> - let start_pos = reg_start_pos regform in - let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env),Nothing,Nothing) - | (V_register regform,false,Just lexp_builder) -> - let start_pos = reg_start_pos regform in - let reg_size = reg_size regform in - ((Action (Write_reg regform Nothing (update_vector_start default_dir start_pos reg_size value)) - (Thunk_frame (E_aux (E_lit (L_aux L_unit l)) (l,intern_annot annot)) t_level l_env l_mem Top), - l_mem,l_env), - Just (next_builder lexp_builder),Nothing) - | (V_boxref n t,true,_) -> - ((Value (V_lit (L_aux L_unit Unknown)), update_mem mode.track_lmem lm n value, l_env), - Nothing,Nothing) - | (v,true,_) -> - ((Error l ("Vector does not contain reg or register values " ^ (string_of_value v)), - lm,l_env), Nothing,Nothing) - | ((V_boxref n t),false, Just lexp_builder) -> - ((Value (in_mem lm n),lm, l_env),Just (next_builder lexp_builder),Nothing) - | (v,false, Just lexp_builder) -> - ((Value v,lm,le), Just (next_builder lexp_builder), Nothing) - | _ -> Assert_extra.failwith "Vector assignment logic incomplete" - end) - | v -> - ((Error l ("Vector access to write of non-vector" ^ (string_of_value v)),lm,l_env),Nothing,Nothing) - end) - | ((Action a s,lm,le),Just lexp_builder,maybe_value) -> - (match (a,is_top_level) with - | ((Write_reg regf Nothing value),true) -> - ((Action (Write_reg regf (Just (n,n)) - (if (vector_length value) = 1 - then (update_vector_start default_dir n 1 value) - else (access_vector value n))) s, lm,le), Nothing, Nothing) - | ((Write_reg regf Nothing value),false) -> - ((Action (Write_reg regf (Just (n,n)) - (if (vector_length value) = 1 - then (update_vector_start default_dir n 1 value) - else (access_vector value n))) s,lm,le), - Just (next_builder lexp_builder), Nothing) - | ((Write_mem id a Nothing value),true) -> - ((Action (Write_mem id a (Just (n,n)) value) s,lm,le), Nothing, Nothing) - | ((Write_mem id a Nothing value),false) -> - ((Action (Write_mem id a (Just (n,n)) value) s,lm,le), Just (next_builder lexp_builder), Nothing) - | _ -> ((Action a s,lm,le), Just (next_builder lexp_builder), Nothing) end) - | e -> e end) - | v -> - ((Error l ("Vector access must be a number given " ^ (string_of_value v)),lm,le),Nothing,Nothing) end) - | (Action a s,lm,le) -> - ((Action a s,lm,le), Just (fun e env -> (LEXP_aux (LEXP_vector lexp e) (l,annot), env)), Nothing) - | e -> (e,Nothing,Nothing) end - | LEXP_vector_range lexp exp1 exp2 -> - match (interp_main mode t_level l_env l_mem exp1) with - | (Value i1, lm, le) -> - (match detaint i1 with - | V_unknown -> ((Value i1,lm,le),Nothing,Nothing) - | V_lit (L_aux (L_num n1) ln1) -> - (match (interp_main mode t_level l_env l_mem exp2) with - | (Value i2,lm,le) -> - (match detaint i2 with - | V_unknown -> ((Value i2,lm,le),Nothing,Nothing) - | V_lit (L_aux (L_num n2) ln2) -> - let next_builder le_builder = - (fun e env -> - let (e1,env) = to_exp mode env i1 in - let (e2,env) = to_exp mode env i2 in - let (lexp,env) = le_builder e env in - (LEXP_aux (LEXP_vector_range lexp e1 e2) (l,annot), env)) in - let (n1,n2) = (natFromInteger n1,natFromInteger n2) in - (match (create_write_message_or_update mode t_level value l_env lm false lexp) with - | ((Value v,lm,le), Just lexp_builder,_) -> - (match (detaint v,is_top_level) with - | (V_vector m inc vs,true) -> - ((Value (V_lit (L_aux L_unit Unknown)), - update_vector_slice mode.track_lmem v value n1 n2 lm, l_env), Nothing, Nothing) - | (V_boxref _ _, true) -> - ((Value (V_lit (L_aux L_unit Unknown)), - update_vector_slice mode.track_lmem v value n1 n2 lm, l_env), Nothing, Nothing) - | (V_vector m inc vs,false) -> - ((Value (slice_vector v n1 n2),lm,l_env), Just (next_builder lexp_builder), Nothing) - | (V_register regform,true) -> - let start_pos = reg_start_pos regform in - let reg_size = reg_size regform in - ((Action (Write_reg regform (Just (n1,n2)) (update_vector_start default_dir start_pos reg_size v)) - (mk_thunk l annot t_level l_env l_mem), - l_mem,l_env), - Just (next_builder lexp_builder), Nothing) - | (V_unknown,_) -> - let inc = n1 < n2 in - let start = if inc then n1 else (n2-1) in - let size = if inc then n2-n1 +1 else n1 -n2 +1 in - ((Value (V_vector start (if inc then IInc else IDec) (List.replicate size V_unknown)), - lm,l_env),Nothing,Nothing) - | _ -> ((Error l "Vector required",lm,le),Nothing,Nothing) end) - | ((Action (Write_reg regf Nothing value) s, lm,le), Just lexp_builder,_) -> - let len = (if n1 < n2 then n2 -n1 else n1 - n2) +1 in - ((Action - (Write_reg regf (Just (n1,n2)) - (if (vector_length value) <= len - then (update_vector_start default_dir n1 len value) - else (slice_vector value n1 n2))) s,lm,le), - Just (next_builder lexp_builder), Nothing) - | ((Action (Write_mem id a Nothing value) s,lm,le), Just lexp_builder,_) -> - ((Action (Write_mem id a (Just (n1,n2)) value) s,lm,le), Just (next_builder lexp_builder), Nothing) - | ((Action a s,lm,le), Just lexp_builder,_ ) -> - ((Action a s,lm,le), Just (next_builder lexp_builder), Nothing) - | e -> e end) - | _ -> ((Error l "Vector slice requires a number", lm, le),Nothing,Nothing) end) - | (Action a s,lm,le) -> - ((Action a s,lm, le), - Just (fun e env -> - let (e1,env) = to_exp mode env i1 in - (LEXP_aux (LEXP_vector_range lexp e1 e) (l,annot), env)), Nothing) - | e -> (e,Nothing,Nothing) end) - | _ -> ((Error l "Vector slice requires a number", lm, le),Nothing,Nothing) end) - | (Action a s,lm,le) -> - ((Action a s, lm,le), Just (fun e env -> (LEXP_aux (LEXP_vector_range lexp e exp2) (l,annot), env)), Nothing) - | e -> (e,Nothing,Nothing) end - | LEXP_field lexp id -> - (match (create_write_message_or_update mode t_level value l_env l_mem false lexp) with - | ((Value (V_record t fexps),lm,le),Just lexp_builder,_) -> - let next_builder = Just (fun e env -> let (lexp,env) = (lexp_builder e env) in - (LEXP_aux (LEXP_field lexp id) (l,annot), env)) in - match (in_env (env_from_list fexps) (get_id id),is_top_level) with - | (Just (V_boxref n t),true) -> - ((Value (V_lit (L_aux L_unit l)), update_mem mode.track_lmem lm n value, l_env),Nothing,Nothing) - | (Just (V_boxref n t),false) -> ((Value (in_mem lm n),lm,l_env),next_builder,Nothing) - | (Just v, true) -> ((Error l "Mutating a field access requires a reg type",lm,le),Nothing,Nothing) - | (Just v,false) -> ((Value v,lm,l_env),next_builder,Nothing) - | (Nothing,_) -> ((Error l "Field not found in specified record",lm,le),Nothing,Nothing) end - | ((Action a s,lm,le), Just lexp_builder,_) -> - let next_builder = Just (fun e env -> let (lexp,env) = (lexp_builder e env) in - (LEXP_aux (LEXP_field lexp id) (l,annot), env)) in - match a with - | Read_reg _ _ -> ((Action a s,lm,le), next_builder, Nothing) - | Read_mem _ _ _ -> ((Action a s,lm,le), next_builder, Nothing) - | Read_mem_tagged _ _ _ -> ((Action a s,lm,le), next_builder, Nothing) - | Call_extern _ _ -> ((Action a s,lm,le), next_builder, Nothing) - | Write_reg ((Form_Reg _ (Just(Typ_aux (Typ_id (Id_aux (Id id') _)) _,_,_,_,_)) _) as regf) Nothing value -> - match in_env subregs id' with - | Just(indexes) -> - match in_env indexes (get_id id) with - | Just ir -> - ((Action - (Write_reg (Form_SubReg id regf ir) Nothing - (update_vector_start default_dir (get_first_index_range ir) - (get_index_range_size ir) value)) s, - lm,le), - (if is_top_level then Nothing else next_builder), Nothing) - | _ -> ((Error l "Internal error, unrecognized write, no field",lm,le),Nothing,Nothing) - end - | Nothing -> ((Error l "Internal error, unrecognized write, no subreges",lm,le),Nothing,Nothing) end - | _ -> ((Error l "Internal error, unrecognized write, no matching action",lm,le),Nothing,Nothing) - end - | e -> e end) - end - -and create_write_message_or_update mode t_level value l_env l_mem is_top_level le = - let _ = debug_fun_enter mode "create_write_message_or_update" [show le] in - let retval = __create_write_message_or_update (indent_mode mode) t_level value l_env l_mem is_top_level le in - let _ = debug_fun_exit mode "create_write_message_or_update" "_" in - retval - -and __interp_letbind mode t_level l_env l_mem (LB_aux lbind (l,annot)) = - match lbind with - | LB_val pat exp -> - match (interp_main mode t_level l_env l_mem exp) with - | (Value v,lm,le) -> - (match match_pattern t_level pat v with - | (true,used_unknown,env) -> ((Value (V_lit (L_aux L_unit l)), lm, (union_env env l_env)),Nothing) - | _ -> ((Error l "Pattern in letbind did not match value",lm,le),Nothing) end) - | (Action a s,lm,le) -> ((Action a s,lm,le),(Just (fun e -> (LB_aux (LB_val pat e) (l,annot))))) - | e -> (e,Nothing) end -end - -and interp_letbind mode t_level l_env l_mem lb = - let _ = debug_fun_enter mode "interp_letbind" [show lb] in - let retval = __interp_letbind (indent_mode mode) t_level l_env l_mem lb in - let _ = debug_fun_exit mode "interp_letbind" "_" in - retval - -and __interp_alias_read mode t_level l_env l_mem (AL_aux alspec (l,annot)) = - let (Env defs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - let stack = Hole_frame redex_id (E_aux (E_id redex_id) (l,(intern_annot annot))) t_level l_env l_mem Top in - let get_reg_typ_name typ = - match typ with - | Typ_aux (Typ_id (Id_aux (Id i) _)) _ -> i - | _ -> Assert_extra.failwith "Alias reg typ not well formed" - end in - match alspec with - | AL_subreg (RI_aux (RI_id reg) (li,((Just (t,_,_,_,_)) as annot'))) subreg -> - let reg_ti = get_reg_typ_name t in - (match in_env subregs reg_ti with - | Just indexes -> - (match in_env indexes (get_id subreg) with - | Just ir -> (Action (Read_reg (Form_SubReg subreg (Form_Reg reg annot' default_dir) ir) Nothing) stack, - l_mem, l_env) - | _ -> (Error l "Internal error, alias spec has unknown field", l_mem, l_env) end) - | _ -> (Error l (String.stringAppend "Internal error: alias spec has unknown register type " reg_ti), - l_mem, l_env) end) - | AL_bit (RI_aux (RI_id reg) (_,annot')) e -> - resolve_outcome (interp_main mode t_level l_env l_mem e) - (fun v le lm -> match v with - | V_lit (L_aux (L_num i) _) -> - let i = natFromInteger i in - (Action (Read_reg (Form_Reg reg annot' default_dir) (Just (i,i))) stack, l_mem, l_env) - | _ -> Assert_extra.failwith "alias bit did not reduce to number" end) - (fun a -> a) (*Should not currently happen as type system enforces constants*) - | AL_slice (RI_aux (RI_id reg) (_,annot')) start stop -> - resolve_outcome (interp_main mode t_level l_env l_mem start) - (fun v lm le -> - match v with - | V_lit (L_aux (L_num start) _) -> - (resolve_outcome - (interp_main mode t_level l_env lm stop) - (fun v le lm -> - (match v with - | V_lit (L_aux (L_num stop) _) -> - let (start,stop) = (natFromInteger start,natFromInteger stop) in - (Action (Read_reg (Form_Reg reg annot' default_dir) (Just (start,stop))) stack, l_mem, l_env) - | _ -> Assert_extra.failwith ("Alias slice evaluted non-lit " ^ (string_of_value v)) - end)) - (fun a -> a)) - | _ -> Assert_extra.failwith ("Alias slice evaluated non-lit "^ string_of_value v) - end) - (fun a -> a) (*Neither action function should occur, due to above*) - | AL_concat (RI_aux (RI_id reg1) (l1, annot1)) (RI_aux (RI_id reg2) annot2) -> - (Action (Read_reg (Form_Reg reg1 annot1 default_dir) Nothing) - (Hole_frame redex_id - (E_aux (E_vector_append (E_aux (E_id redex_id) (l1, (intern_annot annot1))) - (E_aux (E_id reg2) annot2)) - (l,(intern_annot annot))) t_level l_env l_mem Top), l_mem,l_env) - | _ -> Assert_extra.failwith "alias spec not well formed" -end - -and interp_alias_read mode t_level l_env l_mem al = - let _ = debug_fun_enter mode "interp_alias_read" [show al] in - let retval = __interp_alias_read (indent_mode mode) t_level l_env l_mem al in - let _ = debug_fun_exit mode "interp_alias_read" retval in - retval - -let rec eval_toplevel_let handle_action tlevel env mem lbind = - match interp_letbind <| eager_eval=true; track_values=false; track_lmem=false; debug=false; debug_indent="" |> tlevel env mem lbind with - | ((Value v, lm, (LEnv _ le)),_) -> Just le - | ((Action a s,lm,le), Just le_builder) -> - (match handle_action (Action a s) with - | Just value -> - (match s with - | Hole_frame id exp tl lenv lmem s -> - eval_toplevel_let handle_action tl (add_to_env (id,value) lenv) lmem (le_builder exp) - | _ -> Assert_extra.failwith "Top level def evaluation created a thunk frame" end) - | Nothing -> Nothing end) - | _ -> Nothing end - -let rec to_global_letbinds handle_action (Defs defs) t_level = - let (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) = t_level in - match defs with - | [] -> ((Value (V_lit (L_aux L_unit Unknown)), (emem "global_letbinds"), eenv),t_level) - | def::defs -> - match def with - | DEF_val lbind -> - match eval_toplevel_let handle_action t_level eenv (emem "global_letbinds") lbind with - | Just le -> - to_global_letbinds handle_action - (Defs defs) - (Env fdefs instrs default_dir (Map.(union) lets le) regs ctors subregs aliases debug) - | Nothing -> - to_global_letbinds handle_action (Defs defs) - (Env fdefs instrs default_dir lets regs ctors subregs aliases debug) end - | DEF_type (TD_aux tdef _) -> - match tdef with - | TD_enum id ns ids _ -> - let typ = mk_typ_id (get_id id) in - let enum_vals = - Map.fromList - (snd - (List.foldl (fun (c,rst) eid -> (1+c,(get_id eid,V_ctor eid typ (C_Enum c) unitv)::rst)) (0,[]) ids)) in - to_global_letbinds - handle_action (Defs defs) - (Env fdefs instrs default_dir (Map.(union) lets enum_vals) regs ctors subregs aliases debug) - | _ -> to_global_letbinds handle_action (Defs defs) t_level end - | _ -> to_global_letbinds handle_action (Defs defs) t_level - end - end - -let rec extract_default_direction (Defs defs) = match defs with - | [] -> IInc (*When lack of a declared default, go for inc*) - | def::defs -> - match def with - | DEF_default (DT_aux (DT_order (Ord_aux Ord_inc _)) _) -> IInc - | DEF_default (DT_aux (DT_order (Ord_aux Ord_dec _)) _) -> IDec - | _ -> extract_default_direction (Defs defs) end end - -(*TODO Contemplate making execute environment variable instead of constant*) -let to_top_env debug external_functions defs = - let direction = (extract_default_direction defs) in - let t_level = Env (to_fdefs defs) - (extract_instructions "execute" defs) - direction - Map.empty (* empty letbind and enum values, call below will fill in any *) - (to_registers direction defs) - (to_data_constructors defs) (to_register_fields defs) (to_aliases defs) debug in - let (o,t_level) = to_global_letbinds (external_functions direction) defs t_level in - match o with - | (Value _,_,_) -> (Nothing,t_level) - | (o,_,_) -> (Just o,t_level) - end - -let __interp mode external_functions defs exp = - match (to_top_env mode.debug external_functions defs) with - | (Nothing,t_level) -> - interp_main mode t_level eenv (emem "top level") exp - | (Just o,_) -> (o,(emem "top level error"),eenv) - end - -let interp mode external_functions defs exp = - let _ = debug_fun_enter mode "interp" [show exp] in - let retval = __interp (indent_mode mode) external_functions defs exp in - let _ = debug_fun_exit mode "interp" retval in - retval - -let rec __resume_with_env mode stack value = - match (stack,value) with - | (Top,_) -> (Error Unknown "Top hit without expression to evaluate in resume_with_env",eenv) - | (Hole_frame id exp t_level env mem Top,Just value) -> - match interp_main mode t_level (add_to_env (id,value) env) mem exp with | (o,_,e) -> (o,e) end - | (Hole_frame id exp t_level env mem stack,Just value) -> - match resume_with_env mode stack (Just value) with - | (Value v,e) -> - match interp_main mode t_level (add_to_env (id,v) env) mem exp with | (o,_,e) -> (o,e) end - | (Action action stack,e) -> (Action action (Hole_frame id exp t_level env mem stack),e) - | (Error l s,e) -> (Error l s,e) - end - | (Hole_frame id exp t_level env mem stack, Nothing) -> - match resume_with_env mode stack Nothing with - | (Value v,e) -> - match interp_main mode t_level (add_to_env (id,v) env) mem exp with | (o,_,e) -> (o,e) end - | (Action action stack,e) -> (Action action (Hole_frame id exp t_level env mem stack),e) - | (Error l s,e) -> (Error l s,e) - end - | (Thunk_frame exp t_level env mem Top,_) -> - match interp_main mode t_level env mem exp with | (o,_,e) -> (o,e) end - | (Thunk_frame exp t_level env mem stack,value) -> - match resume_with_env mode stack value with - | (Value v,e) -> - match interp_main mode t_level env mem exp with | (o,_,e) -> (o,e) end - | (Action action stack,e) -> (Action action (Thunk_frame exp t_level env mem stack),e) - | (Error l s,e) -> (Error l s,e) - end - end - -and resume_with_env mode stack value = - let _ = debug_fun_enter mode "resume_with_env" [show value] in - let retval = __resume_with_env (indent_mode mode) stack value in - let _ = debug_fun_exit mode "interp" retval in - retval - - -let rec __resume mode stack value = - match (stack,value) with - | (Top,_) -> (Error Unknown "Top hit without expression to evaluate in resume",(emem "top level error"),eenv) - | (Hole_frame id exp t_level env mem Top,Just value) -> - interp_main mode t_level (add_to_env (id,value) env) mem exp - | (Hole_frame id exp t_level env mem Top,Nothing) -> - (Error Unknown "Top hole frame hit wihtout a value in resume", mem, env) - | (Hole_frame id exp t_level env mem stack,Just value) -> - match resume mode stack (Just value) with - | (Value v,_,_) -> - interp_main mode t_level (add_to_env (id,v) env) mem exp - | (Action action stack,lm,le) -> (Action action (Hole_frame id exp t_level env mem stack),lm,le) - | (Error l s,lm,le) -> (Error l s,lm,le) - end - | (Hole_frame id exp t_level env mem stack, Nothing) -> - match resume mode stack Nothing with - | (Value v,_,_) -> - interp_main mode t_level (add_to_env (id,v) env) mem exp - | (Action action stack,lm,le) -> (Action action (Hole_frame id exp t_level env mem stack),lm,le) - | (Error l s,lm,le) -> (Error l s,lm,le) - end - | (Thunk_frame exp t_level env mem Top,_) -> - interp_main mode t_level env mem exp - | (Thunk_frame exp t_level env mem stack,value) -> - match resume mode stack value with - | (Value v,_,_) -> interp_main mode t_level env mem exp - | (Action action stack,lm,le) -> (Action action (Thunk_frame exp t_level env mem stack), lm, le) - | (Error l s,lm,le) -> (Error l s,lm,le) - end - end - -and resume mode stack value = - let _ = debug_fun_enter mode "resume" [show value] in - let retval = __resume (indent_mode mode) stack value in - let _ = debug_fun_exit mode "resume" retval in - retval diff --git a/src/lem_interp/0.11/interp_inter_imp.lem b/src/lem_interp/0.11/interp_inter_imp.lem deleted file mode 100644 index 3413494e..00000000 --- a/src/lem_interp/0.11/interp_inter_imp.lem +++ /dev/null @@ -1,1338 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Interp_ast -import Interp -import Interp_lib -import Instruction_extractor -import Set_extra -open import Pervasives -open import Assert_extra -open import Interp_ast -open import Interp_utilities -open import Sail_impl_base -open import Interp_interface - -val intern_reg_value : register_value -> Interp_ast.value -val intern_mem_value : interp_mode -> direction -> memory_value -> Interp_ast.value -val extern_reg_value : reg_name -> Interp_ast.value -> register_value -val extern_with_track: forall 'a. interp_mode -> (Interp_ast.value -> 'a) -> Interp_ast.value -> ('a * maybe (list reg_name)) -val extern_vector_value: Interp_ast.value -> list byte_lifted -val extern_mem_value : Interp_ast.value -> memory_value -val extern_reg : Interp_ast.reg_form -> maybe (nat * nat) -> reg_name - -let make_interpreter_mode eager_eval tracking_values debug = - <| Interp.eager_eval = eager_eval; Interp.track_values = tracking_values; Interp.track_lmem = false; Interp.debug = debug; Interp.debug_indent = "" |>;; - -let make_mode eager_eval tracking_values debug = - <| internal_mode = make_interpreter_mode eager_eval tracking_values debug |>;; -let make_mode_exhaustive debug = - <| internal_mode = <| Interp.eager_eval = true; Interp.track_values = true; Interp.track_lmem = true; Interp.debug = debug; Interp.debug_indent = "" |> |>;; -let tracking_dependencies mode = mode.internal_mode.Interp.track_values -let make_eager_mode mode = <| internal_mode = <| mode.internal_mode with Interp.eager_eval = true |> |>;; -let make_default_mode = fun () -> <| internal_mode = make_interpreter_mode false false false |>;; - -let bitl_to_ibit = function - | Bitl_zero -> (Interp_ast.V_lit (L_aux L_zero Interp_ast.Unknown)) - | Bitl_one -> (Interp_ast.V_lit (L_aux L_one Interp_ast.Unknown)) - | Bitl_undef -> (Interp_ast.V_lit (L_aux L_undef Interp_ast.Unknown)) - | Bitl_unknown -> Interp_ast.V_unknown -end - -let bit_to_ibit = function - | Bitc_zero -> (Interp_ast.V_lit (L_aux L_zero Interp_ast.Unknown)) - | Bitc_one -> (Interp_ast.V_lit (L_aux L_one Interp_ast.Unknown)) -end - -let to_bool = function - | Bitl_zero -> false - | Bitl_one -> true - | Bitl_undef -> Assert_extra.failwith "to_bool given undef" - | Bitl_unknown -> Assert_extra.failwith "to_bool given unknown" -end - -let is_bool = function - | Bitl_zero -> true - | Bitl_one -> true - | Bitl_undef -> false - | Bitl_unknown -> false -end - -let bitl_from_ibit b = - let b = Interp.detaint b in - match b with - | Interp_ast.V_lit (L_aux L_zero _) -> Bitl_zero - | Interp_ast.V_vector _ _ [Interp_ast.V_lit (L_aux L_zero _)] -> Bitl_zero - | Interp_ast.V_lit (L_aux L_one _) -> Bitl_one - | Interp_ast.V_vector _ _ [Interp_ast.V_lit (L_aux L_one _)] -> Bitl_one - | Interp_ast.V_lit (L_aux L_undef _) -> Bitl_undef - | Interp_ast.V_vector _ _ [Interp_ast.V_lit (L_aux L_undef _)] -> Bitl_undef - | Interp_ast.V_unknown -> Bitl_unknown - | _ -> Assert_extra.failwith ("bit_from_ibit given unexpected " ^ (Interp.string_of_value b)) end - -let bits_to_ibits l = List.map bit_to_ibit l -let bitls_to_ibits l = List.map bitl_to_ibit l -let bitls_from_ibits l = List.map bitl_from_ibit l - -let bits_from_ibits l = List.map - (fun b -> - let b = Interp.detaint b in - match b with - | Interp_ast.V_lit (L_aux L_zero _) -> Bitc_zero - | Interp_ast.V_vector _ _ [Interp_ast.V_lit (L_aux L_zero _)] -> Bitc_zero - | Interp_ast.V_lit (L_aux L_one _) -> Bitc_one - | Interp_ast.V_vector _ _ [Interp_ast.V_lit (L_aux L_one _)] -> Bitc_one - | _ -> Assert_extra.failwith ("bits_from_ibits given unexpected " ^ (Interp.string_of_value b)) - end) l - -let rec to_bytes l = match l with - | [] -> [] - | (a::b::c::d::e::f::g::h::rest) -> (Byte_lifted[a;b;c;d;e;f;g;h])::(to_bytes rest) - | _ -> Assert_extra.failwith "to_bytes given list of bits not divisible by 8" -end - -let all_known l = List.all is_bool l -let all_known_bytes l = List.all (fun (Byte_lifted bs) -> List.all is_bool bs) l - -let bits_to_word8 b = - if ((List.length b) = 8) && (all_known b) - then natFromInteger (integerFromBoolList (false,(List.reverse (List.map to_bool b)))) - else Assert_extra.failwith "bits_to_word8 given a non-8 list or one containing ? and u" - -let intern_direction = function - | D_increasing -> Interp_ast.IInc - | D_decreasing -> Interp_ast.IDec -end - -let extern_direction = function - | Interp_ast.IInc -> D_increasing - | Interp_ast.IDec -> D_decreasing -end - -let intern_opcode direction (Opcode v) = - let bits = List.concatMap (fun (Byte(bits)) -> (List.map bit_to_ibit bits)) v in - let direction = intern_direction direction in - Interp_ast.V_vector (if Interp.is_inc(direction) then 0 else (List.length(bits) - 1)) direction bits - -let intern_reg_value v = match v with - | <| rv_bits=[b] |> -> bitl_to_ibit b - | _ -> Interp_ast.V_vector v.rv_start_internal (intern_direction v.rv_dir) (bitls_to_ibits v.rv_bits) -end - -let intern_mem_value mode direction v = - List.reverse v (* match little endian representation *) - $> List.concatMap (fun (Byte_lifted bits) -> bitls_to_ibits bits) - $> fun bits -> - let direction = intern_direction direction in - Interp_ast.V_vector (if Interp.is_inc direction then 0 else (List.length bits) -1) direction bits - -let intern_ifield_value direction v = - let bits = bits_to_ibits v in - let direction = intern_direction direction in - Interp_ast.V_vector (if Interp.is_inc direction then 0 else (List.length(bits) -1)) direction bits - -let extern_slice (d:direction) (start:nat) ((i,j):(nat*nat)) = - match d with - | D_increasing -> (i,j) (*This is the case the thread/concurrecny model expects, so no change needed*) - | D_decreasing -> - let slice_i = start - i in - let slice_j = (i - j) + slice_i in - (slice_i,slice_j) - end - -let extern_reg r slice = match (r,slice) with - | (Interp_ast.Form_Reg (Id_aux (Id x) _) (Just(t,_,_,_,_)) dir,Nothing) -> - Reg x (Interp.reg_start_pos r) (Interp.reg_size r) (extern_direction dir) - | (Interp_ast.Form_Reg (Id_aux (Id x) _) (Just(t,_,_,_,_)) dir,Just(i1,i2)) -> - let start = Interp.reg_start_pos r in - let edir = extern_direction dir in - Reg_slice x start edir (extern_slice edir start (i1, i2)) - | (Interp_ast.Form_SubReg (Id_aux (Id x) _) ((Interp_ast.Form_Reg (Id_aux (Id y) _) _ dir) as main_r) (BF_aux(BF_single i) _), - Nothing) -> - let i = natFromInteger i in - let start = Interp.reg_start_pos main_r in - let edir = extern_direction dir in - Reg_field y start edir x (extern_slice edir start (i,i)) - | (Interp_ast.Form_SubReg (Id_aux (Id x) _) ((Interp_ast.Form_Reg (Id_aux (Id y) _) _ dir) as main_r) (BF_aux(BF_range i j) _), - Nothing) -> - let start = Interp.reg_start_pos main_r in - let edir = extern_direction dir in - Reg_field y start edir x (extern_slice edir start (natFromInteger i,natFromInteger j)) - | (Interp_ast.Form_SubReg (Id_aux (Id x) _) - ((Interp_ast.Form_Reg (Id_aux (Id y) _) _ dir) as main_r) (BF_aux(BF_range i j) _), Just(i1,j1)) -> - let start = Interp.reg_start_pos main_r in - let edir = extern_direction dir in - Reg_f_slice y start edir x (extern_slice edir start (natFromInteger i,natFromInteger j)) - (extern_slice edir start (i1, j1)) - | _ -> Assert_extra.failwith "extern_reg given non-externable reg" -end - -let rec extern_reg_value reg_name v = - match v with - | Interp_ast.V_track v regs -> extern_reg_value reg_name v - | Interp_ast.V_vector_sparse fst stop inc bits default -> - extern_reg_value reg_name (Interp_lib.fill_in_sparse v) - | _ -> - let (internal_start, external_start, direction) = - (match reg_name with - | Reg _ start size dir -> - (start, (if dir = D_increasing then start else (start - (size +1))), dir) - | Reg_slice _ reg_start dir (slice_start, slice_end) -> - ((if dir = D_increasing then slice_start else (reg_start - slice_start)), - slice_start, dir) - | Reg_field _ reg_start dir _ (slice_start, slice_end) -> - ((if dir = D_increasing then slice_start else (reg_start - slice_start)), - slice_start, dir) - | Reg_f_slice _ reg_start dir _ _ (slice_start, slice_end) -> - ((if dir = D_increasing then slice_start else (reg_start - slice_start)), - slice_start, dir) end) in - let bit_list = - (match v with - | Interp_ast.V_vector fst dir bits -> bitls_from_ibits bits - | Interp_ast.V_lit (L_aux L_zero _) -> [Bitl_zero] - | Interp_ast.V_lit (L_aux L_false _) -> [Bitl_zero] - | Interp_ast.V_lit (L_aux L_one _) -> [Bitl_one] - | Interp_ast.V_lit (L_aux L_true _) -> [Bitl_one] - | Interp_ast.V_lit (L_aux L_undef _) -> [Bitl_undef] - | Interp_ast.V_unknown -> [Bitl_unknown] - | _ -> Assert_extra.failwith ("extern_reg_val given non externable value " ^ (Interp.string_of_value v)) end) - in - <| rv_bits=bit_list; - rv_dir=direction; - rv_start=external_start; - rv_start_internal = internal_start |> -end - -let extern_with_track mode f = function - | Interp_ast.V_track v regs -> - (f v, - if mode.internal_mode.Interp.track_values - then (Just (List.map (fun r -> extern_reg r Nothing) (Set_extra.toList regs))) - else Nothing) - | v -> (f v, Nothing) - end - -let rec extern_vector_value v = match v with - | Interp_ast.V_vector _fst _inc bits -> - bitls_from_ibits bits - $> to_bytes - | Interp_ast.V_vector_sparse _fst _stop _inc _bits _default -> - Interp_lib.fill_in_sparse v - $> extern_vector_value - | Interp_ast.V_track v _ -> extern_vector_value v - | _ -> Assert_extra.failwith ("extern_vector_value received non-externable value " ^ (Interp.string_of_value v)) -end - -let rec extern_mem_value v = List.reverse (extern_vector_value v) - - -let rec extern_ifield_value i_name field_name v ftyp = match (v,ftyp) with - | (Interp_ast.V_track v regs,_) -> extern_ifield_value i_name field_name v ftyp - | (Interp_ast.V_vector fst inc bits,_) -> bits_from_ibits bits - | (Interp_ast.V_vector_sparse fst stop inc bits default,_) -> - extern_ifield_value i_name field_name (Interp_lib.fill_in_sparse v) ftyp - | (Interp_ast.V_lit (L_aux L_zero _),_) -> [Bitc_zero] - | (Interp_ast.V_lit (L_aux L_false _),_) -> [Bitc_zero] - | (Interp_ast.V_lit (L_aux L_one _),_) -> [Bitc_one] - | (Interp_ast.V_lit (L_aux L_true _),_) -> [Bitc_one] - | (Interp_ast.V_lit (L_aux (L_num i) _),Range (Just n)) -> bit_list_of_integer n i - | (Interp_ast.V_lit (L_aux (L_num i) _),Enum _ n) -> bit_list_of_integer n i - | (Interp_ast.V_lit (L_aux (L_num i) _),_) -> bit_list_of_integer 64 i - | (Interp_ast.V_ctor _ _ (Interp_ast.C_Enum i) _,Enum _ n) -> bit_list_of_integer n (integerFromNat i) - | (Interp_ast.V_ctor _ _ (Interp_ast.C_Enum i) _,_) -> bit_list_of_integer 64 (integerFromNat i) - | _ -> - Assert_extra.failwith ("extern_ifield_value of " ^ i_name ^ " for field " ^ field_name - ^ " given non-externable " ^ (Interp.string_of_value v) ^ " ftyp is " ^ show ftyp) -end - -let rec slice_reg_value v start stop = -(* let _ = Interp.debug_print ("slice_reg_value " ^ show v.rv_start_internal ^ " " ^ show v.rv_start ^ " " ^ show start ^ " " ^ show stop) in*) - let inc = v.rv_dir = D_increasing in - let r_internal_start = if inc then start else (stop - start) + 1 in - let r_start = if inc then r_internal_start else start in -(* let _ = Interp.debug_print (" " ^ " " ^ if inc then "Inc " else "dec " ^ show (List.length (Interp.from_n_to_n - (if inc then (start - v.rv_start_internal) else (v.rv_start_internal - start)) - (if inc then (stop - v.rv_start_internal) else (v.rv_start_internal - stop)) v.rv_bits)) ^ " " ^ show (List.length v.rv_bits) ^ " " ^ show (v.rv_start_internal - start) ^ " " ^ show (v.rv_start_internal - stop) ^ "\n") in*) - <| v with rv_bits = (Interp.from_n_to_n (start - v.rv_start) (stop - v.rv_start) v.rv_bits); - rv_start = r_start; - rv_start_internal = r_internal_start - |> - -let lift_reg_name_to_whole reg_name size = match reg_name with - | Reg _ _ _ _ -> reg_name - | Reg_slice name start dir _ -> Reg name start size dir - | Reg_field name start dir _ _ -> Reg name start size dir - | Reg_f_slice name start dir _ _ _ -> Reg name start size dir -end - -let update_reg_value_slice reg_name v start stop v2 = - let v_internal = intern_reg_value v in - let v2_internal = intern_reg_value v2 in - <| (extern_reg_value (lift_reg_name_to_whole reg_name 0) - (if start = stop then - (Interp.fupdate_vec v_internal start v2_internal) - else - (Interp.fupdate_vector_slice v_internal v2_internal start stop))) - with rv_start = v.rv_start; rv_start_internal = v.rv_start_internal |> - -(*TODO: Only find some sub piece matches, need to look for field/slice sub pieces*) -(*TODO immediate: this will be impacted by need to change slicing *) -let rec find_reg_name reg = function - | [] -> Nothing - | (reg_name,v)::registers -> - match (reg,reg_name) with - | (Reg i start size dir, Reg n start2 size2 dir2) -> - if i = n && size = size2 then (Just v) else find_reg_name reg registers - | (Reg_slice i _ _ (p1,p2), Reg n _ _ _) -> - if i = n then (Just (slice_reg_value v p1 p2)) else find_reg_name reg registers - | (Reg_field i _ _ f (p1,p2), Reg n _ _ _) -> -(* let _ = Interp.debug_print ("find_reg_name " ^ i ^ " field case " ^ show p1 ^ " " ^ show p2 ^ "\n") in*) - if i = n then (Just (slice_reg_value v p1 p2)) else find_reg_name reg registers - | (Reg_slice i _ _ (p1,p2), Reg_slice n _ _ (p3,p4)) -> - if i=n - then if p1=p3 && p2 = p4 then (Just v) - else if p1>=p3 && p2<= p4 then (Just (slice_reg_value v p1 p2)) - else find_reg_name reg registers - else find_reg_name reg registers - | (Reg_field i _ _ f _,Reg_field n _ _ fn _) -> - if i=n && f = fn then (Just v) else find_reg_name reg registers - | (Reg_f_slice i _ _ f _ (p1,p2), Reg_f_slice n _ _ fn _ (p3,p4)) -> - if i=n && f=fn && p1=p3 && p2=p3 then (Just v) else find_reg_name reg registers - | _ -> find_reg_name reg registers -end end - - -let initial_instruction_state top_level main args = - let e_args = match args with - | [] -> [E_aux (E_lit (L_aux L_unit Interp_ast.Unknown)) (Interp_ast.Unknown,Nothing)] - | [arg] -> let (e,_) = Interp.to_exp (make_interpreter_mode true false) Interp.eenv (intern_reg_value arg) in [e] - | args -> List.map fst (List.map (Interp.to_exp (make_interpreter_mode true false) Interp.eenv) - (List.map intern_reg_value args)) end in - Interp.Thunk_frame (E_aux (E_app (Id_aux (Id main) Interp_ast.Unknown) e_args) (Interp_ast.Unknown, Nothing)) - top_level Interp.eenv (Interp.emem "istate top level") Interp.Top - -type interp_value_helper_mode = Ivh_translate | Ivh_decode | Ivh_unsupported | Ivh_illegal | Ivh_analysis -type interp_value_return = - | Ivh_value of Interp_ast.value - | Ivh_value_after_exn of Interp_ast.value - | Ivh_error of decode_error - -let rec interp_to_value_helper debug arg ivh_mode err_str instr direction registers events exn_seen thunk = - let errk_str = match ivh_mode with - | Ivh_translate -> "translate" - | Ivh_analysis -> "analysis" - | Ivh_decode -> "decode" - | Ivh_unsupported -> "supported_instructions" - | Ivh_illegal -> "illegal instruction" end in - let events_out = match events with [] -> Nothing | _ -> Just events end in - let mode = (make_interpreter_mode true false debug) in - match thunk() with - | (Interp.Value value,_,_) -> - if exn_seen - then (Ivh_value_after_exn value, events_out) - else - (match ivh_mode with - | Ivh_translate -> (Ivh_value value, events_out) - | Ivh_analysis -> (Ivh_value value, events_out) - | _ -> - (match value with - | Interp_ast.V_ctor (Id_aux (Id "Some") _) _ _ vinstr -> (Ivh_value vinstr,events_out) - | Interp_ast.V_ctor (Id_aux (Id "None") _) _ _ _ -> - (match (ivh_mode,arg) with - | (Ivh_decode, (Just arg)) -> (Ivh_error (Interp_interface.Not_an_instruction_error arg), events_out) - | (Ivh_illegal, (Just arg)) -> (Ivh_error (Interp_interface.Not_an_instruction_error arg), events_out) - | (Ivh_unsupported, _) -> (Ivh_error (Interp_interface.Unsupported_instruction_error instr), events_out) - | _ -> Assert_extra.failwith "Reached unreachable pattern" end) - | _ -> (Ivh_error (Interp_interface.Internal_error ("Value not an option for " ^ errk_str)), events_out) end) end) - | (Interp.Error l msg,_,_) -> (Ivh_error (Interp_interface.Internal_error msg), events_out) - | (Interp.Action (Interp.Return value) stack,_,_) -> - interp_to_value_helper debug arg ivh_mode err_str instr direction registers events exn_seen - (fun _ -> Interp.resume mode stack (Just value)) - | (Interp.Action (Interp.Call_extern i value) stack,_,_) -> - match List.lookup i (Interp_lib.library_functions direction) with - | Nothing -> (Ivh_error (Interp_interface.Internal_error ("External function not available " ^ i)), events_out) - | Just f -> - interp_to_value_helper debug arg ivh_mode err_str instr direction registers events exn_seen - (fun _ -> Interp.resume mode stack (Just (f value))) - end - | (Interp.Action (Interp.Fail v) stack, _, _) -> - match (Interp.detaint v) with - | Interp_ast.V_ctor (Id_aux (Id "Some") _) _ _ (Interp_ast.V_lit (L_aux (L_string s) _)) -> - (Ivh_error (Interp_interface.Internal_error ("Assert failed: " ^ s)), events_out) - | _ -> (Ivh_error (Interp_interface.Internal_error "Assert failed"), events_out) end - | (Interp.Action (Interp.Exit exp) stack,_,_) -> - interp_to_value_helper debug arg ivh_mode err_str instr direction registers events true - (fun _ -> Interp.resume mode (Interp.set_in_context stack exp) Nothing) - | (Interp.Action (Interp.Read_reg r slice) stack,_,_) -> - let rname = match r with - | Interp_ast.Form_Reg (Id_aux (Id i) _) _ _ -> i - | Interp_ast.Form_SubReg (Id_aux (Id i) _) (Interp_ast.Form_Reg (Id_aux (Id i2) _) _ _) _ -> i2 ^ "." ^ i - | _ -> Assert_extra.failwith "Reg not following expected structure" end in - let err_value = - (Ivh_error (Interp_interface.Internal_error ("Register read of "^ rname^" request in a " ^ errk_str ^ " of " ^ err_str)), - events_out) in - (match registers with - | Nothing -> err_value - | Just(regs) -> - let reg = extern_reg r slice in - match find_reg_name reg regs with - | Nothing -> err_value - | Just v -> - let value = intern_reg_value v in -(* let _ = Interp.debug_print ("Register read of " ^ rname ^ " returning value " ^ (Interp.string_of_value value) ^ "\n") in *) - interp_to_value_helper debug arg ivh_mode err_str instr direction registers events exn_seen - (fun _ -> Interp.resume mode stack (Just value)) end end) - | (Interp.Action (Interp.Write_reg r slice value) stack,_,_) -> - let ext_reg = extern_reg r slice in - let reg_value = extern_reg_value ext_reg value in - interp_to_value_helper debug arg ivh_mode err_str instr direction registers ((E_write_reg ext_reg reg_value)::events) - exn_seen (fun _ -> Interp.resume mode stack Nothing) - | (Interp.Action (Interp.Read_mem _ _ _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Read memory request in a " ^ errk_str)), events_out) - | (Interp.Action (Interp.Read_mem_tagged _ _ _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Read memory tagged request in a " ^ errk_str)), events_out) - | (Interp.Action (Interp.Write_mem _ _ _ _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Write memory request in a " ^ errk_str)), events_out) - | (Interp.Action (Interp.Write_ea _ _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Write ea request in a " ^ errk_str)), events_out) - | (Interp.Action (Interp.Excl_res _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Exclusive result request in a " ^ errk_str)), events_out) - | (Interp.Action (Interp.Write_memv _ _ _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Write memory value request in a " ^ errk_str)), events_out) - | (Interp.Action (Interp.Write_memv_tagged _ _ _ _) _,_,_) -> - (Ivh_error (Interp_interface.Internal_error ("Write memory value tagged request in a " ^ errk_str)), events_out) - | (outcome, _, _) -> - (Ivh_error (Interp_interface.Internal_error ("Non expected action in a " ^ errk_str ^ " " ^ Interp.string_of_outcome outcome)), events_out) -end - -let call_external_functions direction outcome = - match outcome with - | Interp.Action (Interp.Call_extern i value) stack -> - match List.lookup i (Interp_lib.library_functions direction) with - | Nothing -> Nothing - | Just f -> Just (f value) end - | _ -> Nothing end - -let build_context debug defs reads writes write_eas write_vals barriers excl_res externs = - (*TODO add externs to to_top_env*) - match Interp.to_top_env debug call_external_functions defs with - | (_,((Interp.Env _ _ dir _ _ _ _ _ debug) as context)) -> - Context context (if Interp.is_inc(dir) then D_increasing else D_decreasing) - reads writes write_eas write_vals barriers excl_res externs end - - -let translate_address top_level end_flag thunk_name registers address = - let (Address bytes i) = address in - let (Context top_env direction _ _ _ _ _ _ _ _ _) = top_level in - let (Interp.Env _ _ _ _ _ _ _ _ debug) = top_env in - let mode = make_mode true false debug in - let int_mode = mode.internal_mode in - let intern_val = intern_mem_value mode direction (memory_value_of_address end_flag address) in - let val_str = Interp.string_of_value intern_val in - let (arg,_) = Interp.to_exp int_mode Interp.eenv intern_val in - let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in - let (address_error,events) = - interp_to_value_helper debug (Just (Opcode bytes)) Ivh_translate val_str (V_list []) internal_direction - registers [] false - (fun _ -> Interp.resume - int_mode - (Interp.Thunk_frame - (E_aux (E_app (Id_aux (Id thunk_name) Interp_ast.Unknown) [arg]) - (Interp_ast.Unknown, Nothing)) - top_env Interp.eenv (Interp.emem "translate top level") Interp.Top) Nothing) in - match (address_error) with - | Ivh_value addr -> - (address_of_byte_lifted_list (extern_vector_value addr), events) - | Ivh_value_after_exn _ -> - (Nothing, events) - | Ivh_error err -> match err with - | Interp_interface.Internal_error msg -> Assert_extra.failwith msg - | _ -> Assert_extra.failwith "Not an internal error either" end -end - -let value_of_instruction_param direction (name,typ,v) = - let vec = intern_ifield_value direction v in - let v = match vec with - | Interp_ast.V_vector start dir bits -> - match typ with - | Bit -> match bits with | [b] -> b | _ -> Assert_extra.failwith "Expected a bitvector of length 1" end - | Range _ -> Interp_lib.to_num Interp_lib.Unsigned vec - | Enum _ _ -> Interp_lib.to_num Interp_lib.Unsigned vec - | _ -> vec - end - | _ -> Assert_extra.failwith "intern_ifield did not return vector" - end in v - -let intern_instruction direction (name,parms) = - Interp_ast.V_ctor (Interp.id_of_string name) (mk_typ_id "ast") Interp_ast.C_Union - (Interp_ast.V_tuple (List.map (value_of_instruction_param direction) parms)) - -let instruction_analysis top_level end_flag thunk_name regn_to_reg_details registers (instruction : Interp_ast.value) = - let (Context top_env direction _ _ _ _ _ _ _ _ _) = top_level in - let (Interp.Env _ _ _ _ _ _ _ _ debug) = top_env in - let mode = make_mode true false debug in - let int_mode = mode.internal_mode in - let val_str = Interp.string_of_value instruction in - let (arg,_) = Interp.to_exp int_mode Interp.eenv instruction in - let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in - let (analysis_or_error,events) = - interp_to_value_helper debug Nothing Ivh_analysis val_str (V_list []) internal_direction - registers [] false - (fun _ -> Interp.resume - int_mode - (Interp.Thunk_frame - (E_aux (E_app (Id_aux (Id thunk_name) Interp_ast.Unknown) [arg]) - (Interp_ast.Unknown, Nothing)) - top_env Interp.eenv (Interp.emem "instruction analysis top level") Interp.Top) Nothing) in - match (analysis_or_error) with - | Ivh_value analysis -> - (match analysis with - | Interp_ast.V_tuple [Interp_ast.V_list regs1; - Interp_ast.V_list regs2; - Interp_ast.V_list regs3; - Interp_ast.V_list nias; - dia; - ik] -> - let reg_to_reg_name v = match v with - | Interp_ast.V_ctor (Id_aux (Id "RFull") _) _ _ (Interp_ast.V_lit (L_aux (L_string n) _)) -> - let (start,length,direction,_) = regn_to_reg_details n Nothing in - Reg n start length direction - | Interp_ast.V_ctor (Id_aux (Id "RSlice") _) _ _ - (Interp_ast.V_tuple [Interp_ast.V_lit (L_aux (L_string n) _); - Interp_ast.V_lit (L_aux (L_num s1) _); - Interp_ast.V_lit (L_aux (L_num s2) _);]) -> - let (start,length,direction,_) = regn_to_reg_details n Nothing in - Reg_slice n start direction (extern_slice direction start (natFromInteger s1, natFromInteger s2)) - (*Note, this may need to change order depending on the direction*) - | Interp_ast.V_ctor (Id_aux (Id "RSliceBit") _) _ _ - (Interp_ast.V_tuple [Interp_ast.V_lit (L_aux (L_string n) _); - Interp_ast.V_lit (L_aux (L_num s) _);]) -> - let (start,length,direction,_) = regn_to_reg_details n Nothing in - Reg_slice n start direction (extern_slice direction start (natFromInteger s,natFromInteger s)) - | Interp_ast.V_ctor (Id_aux (Id "RField") _) _ _ - (Interp_ast.V_tuple [Interp_ast.V_lit (L_aux (L_string n) _); - Interp_ast.V_lit (L_aux (L_string f) _);]) -> - let (start,length,direction,span) = regn_to_reg_details n (Just f) in - Reg_field n start direction f (extern_slice direction start span) - | _ -> Assert_extra.failwith "Register footprint analysis did not return an element of the specified type" end - in - let get_addr v = match address_of_byte_lifted_list (extern_vector_value v) with - | Just addr -> addr - | Nothing -> failwith "get_nia encountered invalid address" end in - let dia_to_dia = function - | Interp_ast.V_ctor (Id_aux (Id "DIAFP_none") _) _ _ _ -> DIA_none - | Interp_ast.V_ctor (Id_aux (Id "DIAFP_concrete") _) _ _ address -> - DIA_concrete_address (get_addr address) - | Interp_ast.V_ctor (Id_aux (Id "DIAFP_reg") _) _ _ reg -> DIA_register (reg_to_reg_name reg) - | _ -> failwith "Register footprint analysis did not return dia of expected type" end in - let nia_to_nia = function - | Interp_ast.V_ctor (Id_aux (Id "NIAFP_successor") _) _ _ _ -> NIA_successor - | Interp_ast.V_ctor (Id_aux (Id "NIAFP_concrete_address") _) _ _ address -> - NIA_concrete_address (get_addr address) - | Interp_ast.V_ctor (Id_aux (Id "NIAFP_indirect_address") _) _ _ _ -> - NIA_indirect_address - | _ -> failwith "Register footprint analysis did not return nia of expected type" end in - let (regs1,regs2,regs3,nias,dia,ik) = - (List.map reg_to_reg_name regs1, - List.map reg_to_reg_name regs2, - List.map reg_to_reg_name regs3, - List.map nia_to_nia nias, - dia_to_dia dia, - fromInterpValue ik) in - ((regs1,regs2,regs3,nias,dia,ik), events) - | _ -> Assert_extra.failwith "Analysis did not return a four-tuple of lists" end) - | Ivh_value_after_exn _ -> Assert_extra.failwith "Instruction analysis failed" - | Ivh_error err -> match err with - | Interp_interface.Internal_error msg -> Assert_extra.failwith msg - | _ -> Assert_extra.failwith "Not an internal error either" end -end - -let rec find_instruction i = function - | [] -> Nothing - | Instruction_extractor.Skipped::instrs -> find_instruction i instrs - | ((Instruction_extractor.Instr_form name parms effects) as instr)::instrs -> - if i = name - then Just instr - else find_instruction i instrs -end - -let migrate_typ = function - | Instruction_extractor.IBit -> Bit - | Instruction_extractor.IBitvector len -> Bvector len - | Instruction_extractor.IRange len -> Range len - | Instruction_extractor.IEnum s max -> Enum s max - | Instruction_extractor.IOther -> Other -end - - -let interp_value_to_instr_external top_level instr = - let (Context (Interp.Env _ instructions _ _ _ _ _ _ debug) _ _ _ _ _ _ _ _ _ _) = top_level in - match instr with - | Interp_ast.V_ctor (Id_aux (Id i) _) _ _ parm -> - match (find_instruction i instructions) with - | Just(Instruction_extractor.Instr_form name parms effects) -> - match (parm,parms) with - | (Interp_ast.V_lit (L_aux L_unit _),[]) -> (name, []) - | (value,[(p_name,ie_typ)]) -> - let t = migrate_typ ie_typ in - (name, [(p_name,t, (extern_ifield_value name p_name value t))]) - | (Interp_ast.V_tuple vals,parms) -> - (name, - (Interp_utilities.map2 (fun value (p_name,ie_typ) -> - let t = migrate_typ ie_typ in - (p_name,t,(extern_ifield_value name p_name value t))) vals parms)) - | _ -> Assert_extra.failwith "decoded instruction doesn't match expectation" - end - | _ -> Assert_extra.failwith ("failed to find instruction " ^ i) - end - | _ -> Assert_extra.failwith "decoded instruction not a constructor" - end - - -let decode_to_instruction top_level registers value : instruction_or_decode_error = - let (Context ((Interp.Env _ instructions _ _ _ _ _ _ debug) as top_env) direction _ _ _ _ _ _ _ _ _) = top_level in - let mode = make_interpreter_mode true false debug in - let intern_val = intern_opcode direction value in - let val_str = Interp.string_of_value intern_val in - let (arg,_) = Interp.to_exp mode Interp.eenv intern_val in - let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in - let (instr_decoded_error,events) = - interp_to_value_helper debug (Just value) Ivh_decode val_str (V_list []) internal_direction registers [] false - (fun _ -> Interp.resume - mode - (Interp.Thunk_frame - (E_aux (E_app (Id_aux (Id "decode") Interp_ast.Unknown) [arg]) (Interp_ast.Unknown, Nothing)) - top_env Interp.eenv (Interp.emem "decode top level") Interp.Top) Nothing) in - match (instr_decoded_error) with - | Ivh_value instr -> - (* let instr_external = interp_value_to_instr_external top_level instr in*) - let (instr_decoded_error,events) = - interp_to_value_helper debug (Just value) Ivh_unsupported val_str instr (*instr_external*) internal_direction - registers [] false - (fun _ -> Interp.resume - mode - (Interp.Thunk_frame - (E_aux (E_app (Id_aux (Id "supported_instructions") Interp_ast.Unknown) [arg]) - (Interp_ast.Unknown, Nothing)) - top_env Interp.eenv (Interp.emem "decode second top level") Interp.Top) Nothing) in - match (instr_decoded_error) with - | Ivh_value _ -> IDE_instr instr (*instr_external*) - | Ivh_value_after_exn v -> - Assert_extra.failwith "supported_instructions called exit, so support will be needed for that now" - | Ivh_error err -> IDE_decode_error err - end - | Ivh_value_after_exn _ -> - Assert_extra.failwith ("Decode of " ^ val_str ^ " called exit.") - | Ivh_error err -> IDE_decode_error err -end - - -let decode_to_istate (top_level:context) registers (value:opcode) : i_state_or_error = - let (Context top_env _ _ _ _ _ _ _ _ _ _) = top_level in - match decode_to_instruction top_level registers value with - | IDE_instr instr -> - let mode = make_interpreter_mode true false in - let (arg,_) = Interp.to_exp mode Interp.eenv instr in - Instr instr - (IState (Interp.Thunk_frame - (E_aux (E_app (Id_aux (Id "execute") Interp_ast.Unknown) [arg]) (Interp_ast.Unknown,Nothing)) - top_env Interp.eenv (Interp.emem "execute") Interp.Top) - top_level) - | IDE_decode_error de -> Decode_error de - end - - -let instr_external_to_interp_value top_level instr = - let (Context _ direction _ _ _ _ _ _ _ _ _) = top_level in - let (name,parms) = instr in - - let get_value (_,typ,v) = - let vec = intern_ifield_value direction v in - match vec with - | Interp_ast.V_vector start dir bits -> - match typ with - | Bit -> match bits with | [b] -> b | _ -> Assert_extra.failwith "Expected a bitvector of length 1" end - | Range _ -> Interp_lib.to_num Interp_lib.Unsigned vec - | Enum _ _ -> Interp_lib.to_num Interp_lib.Unsigned vec - | _ -> vec - end - | _ -> Assert_extra.failwith "intern_ifield did not return vector" - end in - - let parmsV = match parms with - | [] -> Interp_ast.V_lit (L_aux L_unit Unknown) - | _ -> Interp_ast.V_tuple (List.map get_value parms) - end in - (*This type shouldn't be hard-coded*) - Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id name) Interp_ast.Unknown) - (mk_typ_id "ast") Interp_ast.C_Union parmsV - -val instruction_to_istate : context -> Interp_ast.value -> instruction_state -let instruction_to_istate (top_level:context) (instr:Interp_ast.value) : instruction_state = - let mode = make_interpreter_mode true false in - let (Context top_env _ _ _ _ _ _ _ _ _ _) = top_level in - let ast_node = fst (Interp.to_exp mode Interp.eenv instr) in - (IState - (Interp.Thunk_frame - (E_aux (E_app (Id_aux (Id "execute") Interp_ast.Unknown) [ast_node]) - (Interp_ast.Unknown,Nothing)) - top_env Interp.eenv (Interp.emem "execute") Interp.Top) - top_level) - -let rec interp_to_outcome mode context thunk = - let (Context _ direction mem_reads mem_reads_tagged mem_writes mem_write_eas mem_write_vals mem_write_vals_tagged barriers excl_res spec_externs) = context in - let internal_direction = if direction = D_increasing then Interp_ast.IInc else Interp_ast.IDec in - match thunk () with - | (Interp.Value _,lm,le) -> (Done,lm) - | (Interp.Error l msg,lm,le) -> (Error msg,lm) - | (Interp.Action a next_state,lm,le) -> - (match a with - | Interp.Read_reg reg_form slice -> - (Read_reg (extern_reg reg_form slice) - (fun v -> - let v = (intern_reg_value v) in - let v = if mode.internal_mode.Interp.track_values then (Interp_ast.V_track v (Set.fromList [reg_form])) else v in - IState (Interp.add_answer_to_stack next_state v) context), lm) - | Interp.Write_reg reg_form slice value -> - let reg_name = extern_reg reg_form slice in - (Write_reg reg_name (extern_reg_value reg_name value) (IState next_state context),lm) - | Interp.Read_mem (Id_aux (Id i) _) value slice -> - (match List.lookup i mem_reads with - | (Just (MR read_k f)) -> - let (location, length, tracking) = (f mode value) in - if (List.length location) = 8 - then let address_int = match (maybe_all (List.map byte_of_byte_lifted location)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing end in - Read_mem read_k (Address_lifted location address_int) length tracking - (fun v -> IState (Interp.add_answer_to_stack next_state (intern_mem_value mode direction v)) context) - else Error ("Memory address on read is not 64 bits") - | _ -> Error ("Memory function " ^ i ^ " not found") - end , lm) - | Interp.Read_mem_tagged (Id_aux (Id i) _) value slice -> - (match List.lookup i mem_reads_tagged with - | (Just (MRT read_k f)) -> - let (location, length, tracking) = (f mode value) in - if (List.length location) = 8 - then let address_int = match (maybe_all (List.map byte_of_byte_lifted location)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing end in - Read_mem_tagged read_k (Address_lifted location address_int) length tracking - (fun (tag, v) -> IState (Interp.add_answer_to_stack next_state (Interp_ast.V_tuple ([(bitl_to_ibit tag);(intern_mem_value mode direction v)]))) context) - else Error ("Memory address on read is not 64 bits") - | _ -> Error ("Memory function " ^ i ^ " not found") - end , lm) - | Interp.Write_mem (Id_aux (Id i) _) loc_val slice write_val -> - (match List.lookup i mem_writes with - | (Just (MW write_k f return)) -> - let (location, length, tracking) = (f mode loc_val) in - let (value, v_tracking) = extern_with_track mode extern_mem_value write_val in - if (List.length location) = 8 - then let address_int = match (maybe_all (List.map byte_of_byte_lifted location)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing end in - Write_mem write_k (Address_lifted location address_int) - length tracking value v_tracking - (fun b -> - match return with - | Nothing -> (IState (Interp.add_answer_to_stack next_state Interp.unitv) context) - | Just return_bool -> return_bool (IState next_state context) b end) - else Error "Memory address on write is not 64 bits" - | _ -> Error ("Memory function " ^ i ^ " not found") - end , lm) - | Interp.Write_ea (Id_aux (Id i) _) loc_val -> - (match List.lookup i mem_write_eas with - | (Just (MEA write_k f)) -> - let (location, length, tracking) = (f mode loc_val) in - if (List.length location) = 8 - then let address_int = match (maybe_all (List.map byte_of_byte_lifted location)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing end in - Write_ea write_k (Address_lifted location address_int) length tracking (IState next_state context) - else Error "Memory address for write is not 64 bits" - | _ -> Error ("Memory function " ^ i ^ " to signal impending write, not found") end, lm) - | Interp.Excl_res (Id_aux (Id i) _) -> - (match excl_res with - | (Just (i', ER return)) -> - Excl_res (fun b -> - match return with - | Nothing -> (IState (Interp.add_answer_to_stack next_state Interp.unitv) context) - | Just return_bool -> return_bool (IState next_state context) b end) - | _ -> Error ("Exclusive result function, not provided") end, lm) - | Interp.Write_memv (Id_aux (Id i) _) address_val write_val -> - (match List.lookup i mem_write_vals with - | (Just (MV parmf return)) -> - let (value, v_tracking) = - match (Interp.detaint write_val) with - | Interp_ast.V_tuple[_;v] -> extern_with_track mode extern_mem_value (Interp.retaint write_val v) - | _ -> extern_with_track mode extern_mem_value write_val end in - let location_opt = match parmf mode address_val with - | Nothing -> Nothing - | Just mv -> let address_int = match (maybe_all (List.map byte_of_byte_lifted mv)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing end in Just (Address_lifted mv address_int) end - in - Write_memv location_opt value v_tracking - (fun b -> - match return with - | Nothing -> (IState (Interp.add_answer_to_stack next_state Interp.unitv) context) - | Just return_bool -> return_bool (IState next_state context) b end) - | _ -> Error ("Memory function " ^ i ^ " not found") end, lm) - | Interp.Write_memv_tagged (Id_aux (Id i) _) address_val tag_val write_val -> - (match List.lookup i mem_write_vals_tagged with - | (Just (MVT parmf return)) -> - let (value, v_tracking) = - match (Interp.detaint write_val) with - | Interp_ast.V_tuple[_;v] -> extern_with_track mode extern_mem_value (Interp.retaint write_val v) - | _ -> extern_with_track mode extern_mem_value write_val end in - let location_opt = match parmf mode address_val with - | Nothing -> Nothing - | Just mv -> let address_int = match (maybe_all (List.map byte_of_byte_lifted mv)) with - | Just bs -> Just (integer_of_byte_list bs) - | _ -> Nothing end in Just (Address_lifted mv address_int) end - in - Write_memv_tagged location_opt ((bitl_from_ibit tag_val), value) v_tracking - (fun b -> - match return with - | Nothing -> (IState (Interp.add_answer_to_stack next_state Interp.unitv) context) - | Just return_bool -> return_bool (IState next_state context) b end) - | _ -> Error ("Memory function " ^ i ^ " not found") end, lm) - | Interp.Barrier (Id_aux (Id i) _) lval -> - (match List.lookup i barriers with - | Just barrier -> - Barrier barrier (IState next_state context) - | _ -> Error ("Barrier " ^ i ^ " function not found") end, lm) - | Interp.Footprint (Id_aux (Id i) _) lval -> - (Footprint (IState next_state context), lm) - | Interp.Nondet exps tag -> - (match tag with - | Tag_unknown _ -> - let possible_states = List.map (Interp.set_in_context next_state) exps in - let cleared_possibles = List.map Interp.clear_stack_state possible_states in - Analysis_non_det (List.map (fun i -> IState i context) cleared_possibles) (IState next_state context) - | _ -> - let nondet_states = List.map (Interp.set_in_context next_state) exps in - Nondet_choice (List.map (fun i -> IState i context) nondet_states) (IState next_state context) end, lm) - | Interp.Call_extern i value -> - (match List.lookup i ((Interp_lib.library_functions internal_direction) ++ spec_externs) with - | Nothing -> (Error ("External function not available " ^ i), lm) - | Just f -> - if (mode.internal_mode.Interp.eager_eval) - then interp_to_outcome mode context - (fun _ -> Interp.resume mode.internal_mode next_state (Just (f value))) - else let new_v = f value in - (Internal (Just i) - (Just (fun _ -> (Interp.string_of_value value) ^ "=>" ^ (Interp.string_of_value new_v))) - (IState (Interp.add_answer_to_stack next_state new_v) context), lm) - end) - | Interp.Return value -> - interp_to_outcome mode context (fun _ -> Interp.resume mode.internal_mode next_state (Just value)) - | Interp.Step l Nothing Nothing -> (Internal Nothing Nothing (IState next_state context), lm) - | Interp.Step l (Just name) Nothing -> (Internal (Just name) Nothing (IState next_state context), lm) - | Interp.Step l (Just name) (Just value) -> - (Internal (Just name) (Just (fun _ -> Interp.string_of_value value)) (IState next_state context), lm) - | Interp.Fail value -> - (match value with - | Interp_ast.V_ctor (Id_aux (Id "Some") _) _ _ (Interp_ast.V_lit (L_aux (L_string s) _)) -> (Fail (Just s),lm) - | _ -> (Fail Nothing,lm) end) - | Interp.Exit e -> - (Escape (match e with - | E_aux (E_lit (L_aux L_unit _)) _ -> Nothing - | _ -> Just (IState (Interp.set_in_context next_state e) context) end) - (IState next_state context), - (snd (Interp.get_stack_state next_state))) - | _ -> Assert_extra.failwith "Action not as expected: consider if a deiid could have appeared" - end ) - end - - - -(*Update slice potentially here*) -let reg_size = function - | Reg i _ size _ -> size - | Reg_slice i _ _ (p1,p2) -> if p1 < p2 then (p2-p1 +1) else (p1-p2 +1) - | Reg_field i _ _ f (p1,p2) -> if p1 < p2 then (p2-p1 +1) else (p1-p2 +1) - | Reg_f_slice i _ _ f _ (p1,p2) -> if p1 < p2 then p2-p1 +1 else p1-p2+1 -end - - -let interp mode (IState interp_state context) = - match interp_to_outcome mode context (fun _ -> Interp.resume mode.internal_mode interp_state Nothing) with - | (o,_) -> o -end - - -(*ie_loop returns a tuple of event list, and a tuple ofinternal interpreter memory, bool to indicate normal or exceptional termination*) -let rec ie_loop mode register_values (IState interp_state context) = - let (Context _ direction externs reads reads_tagged writes write_eas write_vals write_vals_tagged barriers excl_res) = context in - let unknown_reg size = - <| rv_bits = (List.replicate size Bitl_unknown); - rv_start = 0; - rv_start_internal = (if direction = D_increasing then 0 else (size-1)); - rv_dir = direction |> in - let unknown_mem size = List.replicate size (Byte_lifted (List.replicate 8 Bitl_unknown)) in - match interp_to_outcome mode context (fun _ -> Interp.resume mode.internal_mode interp_state Nothing) with - | (Done,lm) -> ([],(lm,true)) - | (Error msg,lm) -> ([E_error msg],(lm,false)) - | (Escape Nothing i_state,lm) -> ([E_escape],(lm,false)) - (*Do we want to record anything about the escape expression, which may be a function call*) - | (Escape _ i_state,lm) -> ([E_escape],(lm,false)) - | (Fail _,lm) -> ([E_escape],(lm,false)) - | (Read_reg reg i_state_fun,_) -> - let v = (match register_values with - | Nothing -> unknown_reg (reg_size reg) - | Just(registers) -> match find_reg_name reg registers with - | Nothing -> unknown_reg (reg_size reg) - | Just v -> v end end) in - let (events,analysis_data) = ie_loop mode register_values (i_state_fun v) in - ((E_read_reg reg)::events,analysis_data) - | (Write_reg reg value i_state, _)-> - let (events,analysis_data) = ie_loop mode register_values i_state in - ((E_write_reg reg value)::events,analysis_data) - | (Read_mem read_k loc length tracking i_state_fun, _) -> - let (events,analysis_data) = ie_loop mode register_values (i_state_fun (unknown_mem length)) in - ((E_read_mem read_k loc length tracking)::events,analysis_data) - | (Read_mem_tagged read_k loc length tracking i_state_fun, _) -> - let (events,analysis_data) = ie_loop mode register_values (i_state_fun (Bitl_unknown, (unknown_mem length))) in - ((E_read_memt read_k loc length tracking)::events,analysis_data) - | (Write_mem write_k loc length tracking value v_tracking i_state_fun, _) -> - let (events,analysis_data) = ie_loop mode register_values (i_state_fun true) in - let (events',analysis_data) = ie_loop mode register_values (i_state_fun false) in - (*TODO: consider if lm and lm should be distinct and merged*) - ((E_write_mem write_k loc length tracking value v_tracking)::(events++events'),analysis_data) - | (Write_ea write_k loc length tracking i_state, _) -> - let (events,analysis_data) = ie_loop mode register_values i_state in - ((E_write_ea write_k loc length tracking)::events,analysis_data) - | (Excl_res i_state_fun, _) -> - let (events,analysis_data) = ie_loop mode register_values (i_state_fun true) in - let (events',analysis_data) = ie_loop mode register_values (i_state_fun false) in - (*TODO: consider if lm and lm should be merged*) - (E_excl_res :: (events ++ events'), analysis_data) - | (Write_memv opt_address value tracking i_state_fun, _) -> - let (events,analysis_data) = ie_loop mode register_values (i_state_fun true) in - let (events',analysis_data) = ie_loop mode register_values (i_state_fun false) in - (*TODO: consider if lm and lm should be merged*) - ((E_write_memv opt_address value tracking)::(events++events'),analysis_data) - | (Write_memv_tagged opt_address value tracking i_state_fun, _) -> - let (events,analysis_data) = ie_loop mode register_values (i_state_fun true) in - let (events',analysis_data) = ie_loop mode register_values (i_state_fun false) in - (*TODO: consider if lm and lm should be merged*) - ((E_write_memvt opt_address value tracking)::(events++events'),analysis_data) - | (Barrier barrier_k i_state, _) -> - let (events,analysis_data) = ie_loop mode register_values i_state in - ((E_barrier barrier_k)::events,analysis_data) - | (Footprint i_state, _) -> - let (events,analysis_data) = ie_loop mode register_values i_state in - (E_footprint::events,analysis_data) - | (Internal _ _ next, _) -> (ie_loop mode register_values next) - | (Analysis_non_det possible_istates i_state,_) -> - if possible_istates = [] - then ie_loop mode register_values i_state - else - let (possible_events,possible_states) = List.unzip(List.map (ie_loop mode register_values) possible_istates) in - let (unified_mem,update_mem) = List.foldr - (fun (lm,terminated_normally) (mem,update_mem) -> - if terminated_normally && update_mem - then (Interp.merge_lmems lm mem, true) - else if terminated_normally - then (lm, true) - else (mem, false)) - (List_extra.head possible_states) (List_extra.tail possible_states) in - let updated_i_state = - if update_mem - then match i_state with - | (IState interp_state context) -> IState (Interp.update_stack_state interp_state unified_mem) context end - else i_state in - let (events,analysis_data) = ie_loop mode register_values updated_i_state in - ((List.concat possible_events)++events, analysis_data) - | _ -> Assert_extra.failwith "interp_to_outcome may have produced a nondet action" - end ;; - -val interp_exhaustive : bool -> maybe (list (reg_name * register_value)) -> instruction_state -> list event -let interp_exhaustive debug register_values i_state = - let mode = make_mode_exhaustive debug in - match ie_loop mode register_values i_state with - | (events,_) -> events -end - - -val state_to_outcome_s : - (instruction_state -> unit -> (string * string)) -> - interp_mode -> instruction_state -> Sail_impl_base.outcome_s unit -val outcome_to_outcome : - (instruction_state -> unit -> (string * string)) -> - interp_mode -> Interp_interface.outcome -> Sail_impl_base.outcome unit - -let rec outcome_to_outcome pp_instruction_state mode = - let state_to_outcome_s = - state_to_outcome_s pp_instruction_state in - function - | Interp_interface.Read_mem rk addr size _ k -> - Sail_impl_base.Read_mem (rk,addr,size) (fun v -> state_to_outcome_s mode (k v)) - | Interp_interface.Write_mem rk addr size _ mv _ k -> - failwith "Write_mem not supported anymore" - | Interp_interface.Write_ea wk addr size _ state -> - Sail_impl_base.Write_ea (wk,addr,size) (state_to_outcome_s mode state) - | Interp_interface.Excl_res k -> - Sail_impl_base.Excl_res (fun v -> state_to_outcome_s mode (k v)) - | Interp_interface.Write_memv _ mv _ k -> - Sail_impl_base.Write_memv mv (fun v -> state_to_outcome_s mode (k v)) - | Interp_interface.Barrier bk state -> - Sail_impl_base.Barrier bk (state_to_outcome_s mode state) - | Interp_interface.Footprint state -> - Sail_impl_base.Footprint (state_to_outcome_s mode state) - | Interp_interface.Read_reg r k -> - Sail_impl_base.Read_reg r (fun v -> state_to_outcome_s mode (k v)) - | Interp_interface.Write_reg r rv state -> - Sail_impl_base.Write_reg (r,rv) (state_to_outcome_s mode state) - | Interp_interface.Nondet_choice _ _ -> - failwith "Nondet_choice not supported yet" - | Interp_interface.Escape _ _ -> - Sail_impl_base.Escape Nothing - | Interp_interface.Fail maybestring -> - Sail_impl_base.Fail maybestring - | Interp_interface.Internal maybestring maybeprint state -> - Sail_impl_base.Internal (maybestring,maybeprint) (state_to_outcome_s mode state) - | Interp_interface.Analysis_non_det _ _ -> - failwith "Analysis_non_det outcome returned" - | Interp_interface.Done -> - Sail_impl_base.Done () - | Interp_interface.Error message -> - failwith ("Interpreter error: " ^ message) -end - -and state_to_outcome_s pp_instruction_state mode state = - let next_outcome' = interp mode state in - let next_outcome = outcome_to_outcome pp_instruction_state mode next_outcome' in - (next_outcome, - Just ((pp_instruction_state state), - (fun env -> interp_exhaustive mode.internal_mode.Interp.debug (Just env) state)) - ) - -val initial_outcome_s_of_instruction : (instruction_state -> unit -> (string * string)) -> context -> interp_mode -> Interp_ast.value -> Sail_impl_base.outcome_s unit -let initial_outcome_s_of_instruction pp_instruction_state context mode instruction = - let state = instruction_to_istate context instruction in - state_to_outcome_s pp_instruction_state mode state - - -(*This code is no longer uptodate. If no one is using it, then we don't need to fix it -If someone is using it, this will let me know*) -(*let rec rr_ie_loop mode i_state = - let (IState _ (Context _ direction _ _ _ _ _ _)) = i_state in - let unknown_reg size = - <| rv_bits = (List.replicate size Bitl_unknown); - rv_start = 0; - rv_start_internal = (if direction=D_increasing then 0 else (size-1)); - rv_dir = direction |> in - let unknown_mem size = List.replicate size (Byte_lifted (List.replicate 8 Bitl_unknown)) in - match (interp mode i_state) with - | Done -> ([],Done) - | Error msg -> ([E_error msg], Error msg) - | Read_reg reg i_state_fun -> ([], Read_reg reg i_state_fun) - | Write_reg reg value i_state-> - let (events,outcome) = (rr_ie_loop mode i_state) in - (((E_write_reg reg value)::events), outcome) - | Read_mem read_k loc length tracking i_state_fun -> - let (events,outcome) = (rr_ie_loop mode (i_state_fun (unknown_mem length))) in - (((E_read_mem read_k loc length tracking)::events),outcome) - | Write_mem write_k loc length tracking value v_tracking i_state_fun -> - let (events,outcome) = (rr_ie_loop mode (i_state_fun true)) in - (((E_write_mem write_k loc length tracking value v_tracking)::events),outcome) - | Barrier barrier_k i_state -> - let (events,outcome) = (rr_ie_loop mode i_state) in - (((E_barrier barrier_k)::events),outcome) - | Internal _ _ next -> (rr_ie_loop mode next) - end ;; - -let rr_interp_exhaustive mode i_state events = - let (events',outcome) = rr_ie_loop mode i_state in ((events ++ events'),outcome) -*) - - -let instruction_kind_of_event nia_reg : event -> maybe instruction_kind = function - (* this is a hack to avoid adding special events for AArch64 transactional-memory *) - | E_read_reg (Reg "TMStartEffect" 63 64 D_decreasing) -> Just (IK_trans Transaction_start) - | E_write_reg (Reg "TMAbortEffect" 63 64 D_decreasing) _ -> Just (IK_trans Transaction_abort) - | E_barrier Barrier_TM_COMMIT -> Just (IK_trans Transaction_commit) - - | E_read_mem rk _ _ _ -> Just (IK_mem_read rk) - | E_read_memt rk _ _ _ -> Just (IK_mem_read rk) - | E_write_mem wk _ _ _ _ _ -> Just (IK_mem_write wk) - | E_write_ea wk _ _ _ -> Just (IK_mem_write wk) - | E_excl_res -> Nothing - | E_write_memv _ _ _ -> Nothing - | E_write_memvt _ _ _ -> Nothing - | E_barrier bk -> Just (IK_barrier bk) - | E_footprint -> Nothing - | E_read_reg _ -> Nothing - | E_write_reg reg _ -> - if register_base_name reg = register_base_name nia_reg then Just IK_branch - else Nothing - | E_error s -> failwith ("instruction_kind_of_event error: "^s) - | E_escape -> Nothing (*failwith ("instruction_kind_of_event escape")*) - end -(* TODO: how can we decide, looking only at the output of interp_exhaustive, - that an instruction is a conditional branch? *) - -let regs_in_of_event : event -> list reg_name = function - | E_read_mem _ _ _ _ -> [] - | E_read_memt _ _ _ _ -> [] - | E_write_mem _ _ _ _ _ _ -> [] - | E_write_ea _ _ _ _ -> [] - | E_excl_res -> [] - | E_write_memv _ _ _ -> [] - | E_write_memvt _ _ _ -> [] - | E_barrier _ -> [] - | E_footprint -> [] - | E_read_reg r -> [r] - | E_write_reg _ _ -> [] - | E_error s -> failwith ("regs_in_of_event "^s) - | E_escape -> [] (*failwith ("regs_in_of_event escape")*) - end - -let regs_out_of_event : event -> list reg_name = function - | E_read_mem _ _ _ _ -> [] - | E_read_memt _ _ _ _ -> [] - | E_write_mem _ _ _ _ _ _ -> [] - | E_write_ea _ _ _ _ -> [] - | E_excl_res -> [] - | E_write_memv _ _ _ -> [] - | E_write_memvt _ _ _ -> [] - | E_barrier _ -> [] - | E_footprint -> [] - | E_read_reg _ -> [] - | E_write_reg r _ -> [r] - | E_error s -> failwith ("regs_out_of_event "^s) - | E_escape -> [] (*failwith ("regs_out_of_event escape")*) - end - - -let regs_feeding_memory_access_address_of_event : event -> list reg_name = function - | E_read_mem _ _ _ (Just rs) -> rs - | E_read_mem _ _ _ None -> [] - | E_read_memt _ _ _ (Just rs) -> rs - | E_read_memt _ _ _ None -> [] - | E_write_mem _ _ _ (Just rs) _ _ -> rs - | E_write_mem _ _ _ None _ _ -> [] - | E_write_ea wk _ _ (Just rs) -> rs - | E_write_ea wk _ _ None -> [] - | E_excl_res -> [] - | E_write_memv _ _ _ -> [] - | E_write_memvt _ _ _ -> [] - | E_barrier bk -> [] - | E_footprint -> [] - | E_read_reg _ -> [] - | E_write_reg _ _ -> [] - | E_error s -> failwith ("regs_feeding_memory_access_address_of_event " ^ s) - | E_escape -> [] (*failwith ("regs_feeding_memory_access_address_of_event escape")*) -end - -let nia_address_of_event nia_reg (event: event) : maybe (maybe address) = - (* return Nothing for unknown/undef *) - match event with - | E_write_reg reg reg_value -> - if register_base_name reg = register_base_name nia_reg then - let al = match address_lifted_of_register_value reg_value with - | Just al -> al - | Nothing -> failwith "nia_register_of_event: NIA read not 64 bits" - end in - Just (address_of_address_lifted al) - else Nothing - | _ -> Nothing - end - -let interp_instruction_analysis - top_level - (interp_exhaustive : ((list (reg_name * register_value)) -> list event)) - instruction - nia_reg - (nias_function : (list (maybe address) -> list nia)) - ism environment = - - let es = interp_exhaustive environment in - - let regs_in = List.concatMap regs_in_of_event es in - let regs_out = List.concatMap regs_out_of_event es in - - let regs_feeding_address = List.concatMap regs_feeding_memory_access_address_of_event es in - - let nia_address = List.mapMaybe (nia_address_of_event nia_reg) es in - let nias = nias_function nia_address in - - let dia = DIA_none in (* FIX THIS! *) - - let inst_kind = - match List.mapMaybe (instruction_kind_of_event nia_reg) es with - | [] -> IK_simple - | inst_kind :: [] -> inst_kind - | inst_kind :: inst_kinds -> - if forall (inst_kind' MEM inst_kinds). inst_kind' = inst_kind then - inst_kind - - else if - (forall (inst_kind' MEM (inst_kind :: inst_kinds)). - match inst_kind' with - | IK_mem_read _ -> true - | IK_mem_write _ -> true - | IK_mem_rmw _ -> false - | IK_barrier _ -> false - | IK_branch -> false - | IK_trans _ -> false - | IK_simple -> false - end) - then - match - List.partition - (function IK_mem_read _ -> true | _ -> false end) - (inst_kind :: inst_kinds) - with - | ((IK_mem_read r) :: rs, (IK_mem_write w) :: ws) -> - let () = ensure (forall (r' MEM rs). r' = IK_mem_read r) "more than one kind of read" in - let () = ensure (forall (w' MEM ws). w' = IK_mem_write w) "more than one kind of write" in - IK_mem_rmw (r, w) - | _ -> fail - end - - (* the TSTART instruction can also be aborted so it will have two kinds of events *) - else if (exists (inst_kind' MEM (inst_kind :: inst_kinds)). - inst_kind' = IK_trans Transaction_start) && - (forall (inst_kind' MEM (inst_kind :: inst_kinds)). - inst_kind' = IK_trans Transaction_start - || inst_kind' = IK_trans Transaction_abort) - then - IK_trans Transaction_start - - else - failwith "multiple instruction kinds" - end in - - (regs_in, regs_out, regs_feeding_address, nias, dia, inst_kind) - -let interp_handwritten_instruction_analysis context endianness instruction analysis_function reg_info environment = - fst (instruction_analysis context endianness analysis_function - reg_info (Just environment) instruction) - - - -val print_and_fail_of_inequal : forall 'a. Show 'a => - (string -> unit) -> - (instruction -> string) -> - (string * 'a) -> (string * 'a) -> unit -let print_and_fail_if_inequal - (print_endline,instruction) - (name1,xs1) (name2,xs2) = - if xs1 = xs2 then () - else - let () = print_endline (name1^": "^show xs1) in - let () = print_endline (name2^": "^show xs2) in - failwith (name1^" and "^ name2^" inequal for instruction: \n" ^ Interp.string_of_value instruction) - -let interp_compare_analyses - print_endline - (non_pseudo_registers : set reg_name -> set reg_name) - context - endianness - interp_exhaustive - (instruction : Interp_ast.value) - nia_reg - (nias_function : (list (maybe address) -> list nia)) - ism - environment - analysis_function - reg_info = - let (regs_in1,regs_out1,regs_feeding_address1,nias1,dia1,inst_kind1) = - interp_instruction_analysis context interp_exhaustive instruction nia_reg nias_function ism - environment in - let (regs_in1S,regs_out1S,regs_feeding_address1S,nias1S) = - (Set.fromList regs_in1, - Set.fromList regs_out1, - Set.fromList regs_feeding_address1, - Set.fromList nias1) in - let (regs_in1S,regs_out1S,regs_feeding_addres1S) = - (non_pseudo_registers regs_in1S, - non_pseudo_registers regs_out1S, - non_pseudo_registers regs_feeding_address1S) in - - let (regs_in2,regs_out2,regs_feeding_address2,nias2,dia2,inst_kind2) = - interp_handwritten_instruction_analysis - context endianness instruction analysis_function reg_info environment in - let (regs_in2S,regs_out2S,regs_feeding_address2S,nias2S) = - (Set.fromList regs_in2, - Set.fromList regs_out2, - Set.fromList regs_feeding_address2, - Set.fromList nias2) in - let (regs_in2S,regs_out2S,regs_feeding_addres2S) = - (non_pseudo_registers regs_in2S, - non_pseudo_registers regs_out2S, - non_pseudo_registers regs_feeding_address2S) in - - let aux = (print_endline,instruction) in - let () = (print_and_fail_if_inequal aux) - ("regs_in exhaustive",regs_in1S) - ("regs_in hand",regs_in2S) in - let () = (print_and_fail_if_inequal aux) - ("regs_out exhaustive",regs_out1S) - ("regs_out hand",regs_out2S) in - let () = (print_and_fail_if_inequal aux) - ("regs_feeding_address exhaustive",regs_feeding_address1S) - ("regs_feeding_address hand",regs_feeding_address2S) in - let () = (print_and_fail_if_inequal aux) - ("nias exhaustive",nias1S) - ("nias hand",nias2S) in - let () = (print_and_fail_if_inequal aux) - ("dia exhaustive",dia1) - ("dia hand",dia2) in - let () = (print_and_fail_if_inequal aux) - ("inst_kind exhaustive",inst_kind1) - ("inst_kind hand",inst_kind2) in - - (regs_in1,regs_out1,regs_feeding_address1,nias1,dia1,inst_kind1) - - diff --git a/src/lem_interp/0.11/interp_interface.lem b/src/lem_interp/0.11/interp_interface.lem deleted file mode 100644 index 32744da2..00000000 --- a/src/lem_interp/0.11/interp_interface.lem +++ /dev/null @@ -1,326 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -(* PS NOTES FOR KATHY: - -pls also change: - - decode_to_istate - decode_to_instruction - -to take an opcode as defined above, instead of a value - -and change - -*) - - -open import Sail_impl_base -import Interp -open import Interp_ast -open import Pervasives -open import Num - -open import Assert_extra - -(*Type representing the constructor parameters in instruction, other is a type not representable externally*) -type instr_parm_typ = - | Bit (*A single bit, represented as a one element Bitvector as a value*) - | Bvector of maybe nat (* A bitvector type, with length when statically known *) - | Range of maybe nat (*Internally represented as a number, externally as a bitvector of length nat *) - | Enum of string * nat (*Internally represented as either a number or constructor, externally as a bitvector*) - | Other (*An unrepresentable type, will be represented as Unknown in instruciton form *) - -let {coq} instr_parm_typEqual ip1 ip2 = match (ip1,ip2) with - | (Bit,Bit) -> true - | (Bvector i1,Bvector i2) -> i1 = i2 - | (Range i1,Range i2) -> i1 = i2 - | (Enum s1 i1,Enum s2 i2) -> s1 = s2 && i1 = i2 - | (Other,Other) -> true - | _ -> false -end -let inline ~{coq} instr_parm_typEqual = unsafe_structural_equality - -let {coq} instr_parm_typInequal ip1 ip2 = not (instr_parm_typEqual ip1 ip2) -let inline ~{coq} instr_parm_typInequal = unsafe_structural_inequality - -instance (Eq instr_parm_typ) - let (=) = instr_parm_typEqual - let (<>) ip1 ip2 = not (instr_parm_typEqual ip1 ip2) -end - -let instr_parm_typShow ip = match ip with - | Bit -> "Bit" - | Bvector i -> "Bvector " ^ show i - | Range i -> "Range " ^ show i - | Enum s i -> "Enum " ^ s ^ " " ^ show i - | Other -> "Other" - end - -instance (Show instr_parm_typ) -let show = instr_parm_typShow -end - -(*A representation of the AST node for each instruction in the spec, with concrete values from this call, - and the potential static effects from the funcl clause for this instruction - Follows the form of the instruction in instruction_extractor, but populates the parameters with actual values -*) - - -type instruction_field_value = list bit - -type instruction = (string * list (string * instr_parm_typ * instruction_field_value)) - -let {coq} instructionEqual i1 i2 = match (i1,i2) with - | ((i1,parms1,effects1),(i2,parms2,effects2)) -> i1=i2 && parms1 = parms2 && effects1 = effects2 -end -let inline ~{coq} instructionEqual = unsafe_structural_equality - -let {coq} instructionInequal i1 i2 = not (instructionEqual i1 i2) -let inline ~{coq} instructionInequal = unsafe_structural_inequality - -type v_kind = Bitv | Bytev - -type decode_error = - | Unsupported_instruction_error of Interp_ast.value - | Not_an_instruction_error of opcode - | Internal_error of string - - -let decode_error_compare e1 e2 = - match (e1, e2) with - | (Unsupported_instruction_error i1, Unsupported_instruction_error i2) - -> defaultCompare i1 i2 - | (Unsupported_instruction_error _, _) -> LT - | (_, Unsupported_instruction_error _) -> GT - - | (Not_an_instruction_error o1, Not_an_instruction_error o2) -> defaultCompare o1 o2 - | (Not_an_instruction_error _, _) -> LT - | (_, Not_an_instruction_error _) -> GT - - | (Internal_error s1, Internal_error s2) -> compare s1 s2 - (* | (Internal_error _, _) -> LT *) - (* | (_, Internal_error _) -> GT *) - end - -let decode_error_less e1 e2 = decode_error_compare e1 e2 = LT -let decode_error_less_eq e1 e2 = decode_error_compare e1 e2 <> GT -let decode_error_greater e1 e2 = decode_error_compare e1 e2 = GT -let decode_error_greater_eq e1 e2 = decode_error_compare e1 e2 <> LT - -instance (Ord decode_error) - let compare = decode_error_compare - let (<) = decode_error_less - let (<=) = decode_error_less_eq - let (>) = decode_error_greater - let (>=) = decode_error_greater_eq -end - -let decode_error_equal e1 e2 = (decode_error_compare e1 e2) = EQ -let decode_error_inequal e1 e2 = not (decode_error_equal e1 e2) - -instance (Eq decode_error) - let (=) = decode_error_equal - let (<>) = decode_error_inequal -end - - -type interpreter_state = Interp.stack (*Deem abstract*) -(* Will come from a .lem file generated by Sail, bound to a 'defs' identifier *) -type specification = Interp_ast.defs Interp_ast.tannot (*Deem abstract*) -type interpreter_mode = Interp.interp_mode (*Deem abstract*) -type interp_mode = <| internal_mode: interpreter_mode |> -val make_mode : (*eager*) bool -> (*tracking*) bool -> interp_mode -val tracking_dependencies : interp_mode -> bool - - - -(*Map between external functions as preceived from a Sail spec and the actual implementation of the function *) -type external_functions = list (string * (Interp_ast.value -> Interp_ast.value)) - -(*Maps between the memory functions as preceived from a Sail spec and the values needed for actions in the memory model*) -type barriers = list (string * barrier_kind) -type memory_parameter_transformer = interp_mode -> Interp_ast.value -> (memory_value * nat * maybe (list reg_name)) -type optional_memory_transformer = interp_mode -> Interp_ast.value -> maybe memory_value -type memory_read = MR of read_kind * memory_parameter_transformer -type memory_reads = list (string * memory_read) -type memory_read_tagged = MRT of read_kind * memory_parameter_transformer -type memory_read_taggeds = list (string * memory_read_tagged) -type memory_write_ea = MEA of write_kind * memory_parameter_transformer -type memory_write_eas = list (string * memory_write_ea) -type memory_write = MW of write_kind * memory_parameter_transformer * (maybe (instruction_state -> bool -> instruction_state)) -and memory_writes = list (string * memory_write) -and memory_write_val = MV of optional_memory_transformer * (maybe (instruction_state -> bool -> instruction_state)) -and memory_write_vals = list (string * memory_write_val) -and excl_res_t = ER of maybe (instruction_state -> bool -> instruction_state) -and excl_res = maybe (string * excl_res_t) -and memory_write_val_tagged = MVT of optional_memory_transformer * (maybe (instruction_state -> bool -> instruction_state)) -and memory_write_vals_tagged = list (string * memory_write_val_tagged) - -(* Definition information needed to run an instruction *) -and context = - Context of Interp.top_level * direction * - memory_reads * memory_read_taggeds * memory_writes * memory_write_eas * memory_write_vals * memory_write_vals_tagged * barriers * excl_res * external_functions - -(* An instruction in flight *) -and instruction_state = IState of interpreter_state * context - - -type outcome = -(* Request to read N bytes at address *) -(* The register list, used when mode.track_values, is those that the address depended on *) -| Read_mem of read_kind * address_lifted * nat * maybe (list reg_name) * (memory_value -> instruction_state) -| Read_mem_tagged of read_kind * address_lifted * nat * maybe (list reg_name) * ((bit_lifted * memory_value) -> instruction_state) - -(* Request to write memory *) -| Write_mem of write_kind * address_lifted * nat * maybe (list reg_name) - * memory_value * maybe (list reg_name) * (bool -> instruction_state) - -(* Request the result of store-exclusive *) -| Excl_res of (bool -> instruction_state) - -(* Tell the system a write is imminent, at address lifted tainted by register list, of size nat *) -| Write_ea of write_kind * address_lifted * nat * maybe (list reg_name) * instruction_state - -(* Request to write memory at last signaled address. Memory value should be 8* the size given in Write_ea *) -| Write_memv of maybe address_lifted * memory_value * maybe (list reg_name) * (bool -> instruction_state) -| Write_memv_tagged of maybe address_lifted * (bit_lifted * memory_value) * maybe (list reg_name) * (bool -> instruction_state) - -(* Request a memory barrier *) -| Barrier of barrier_kind * instruction_state - -(* Tell the system to dynamically recalculate dependency footprint *) -| Footprint of instruction_state - -(* Request to read register, will track dependency when mode.track_values *) -| Read_reg of reg_name * (register_value -> instruction_state) - -(* Request to write register *) -| Write_reg of reg_name * register_value * instruction_state - -(* List of instruciton states to be run in parallel, any order*) -| Nondet_choice of list instruction_state * instruction_state - -(* Escape the current instruction, for traps, some sys calls, interrupts, etc. Can optionally - provide a handler. The non-optional instruction_state is what we would be doing if we're - not escaping. This is for exhaustive interp *) -| Escape of maybe instruction_state * instruction_state - -(*Result of a failed assert with possible error message to report*) -| Fail of maybe string - -(* Stop for incremental stepping, function can be used to display function call data *) -| Internal of maybe string * maybe (unit -> string) * instruction_state - -(* Analysis can lead to non_deterministic evaluation, represented with this outcome *) -(*Note: this should not be externally visible *) -| Analysis_non_det of list instruction_state * instruction_state - -(*Completed interpreter*) -| Done - -(*Interpreter error*) -| Error of string - - -(* Functions to build up the initial state for interpretation *) -val build_context : bool -> specification -> memory_reads -> memory_read_taggeds-> memory_writes -> memory_write_eas -> memory_write_vals -> memory_write_vals_tagged -> barriers -> excl_res -> external_functions -> context -val initial_instruction_state : context -> string -> list register_value -> instruction_state - (* string is a function name, list of value are the parameters to that function *) - -type instruction_or_decode_error = - | IDE_instr of Interp_ast.value - | IDE_decode_error of decode_error - -(** propose to remove the following type and use the above instead *) -type i_state_or_error = - | Instr of Interp_ast.value * instruction_state - | Decode_error of decode_error - - -(** PS:I agree. propose to remove this: Function to decode an instruction and build the state to run it*) -val decode_to_istate : context -> maybe (list (reg_name * register_value)) -> opcode -> i_state_or_error - -(** propose to add this, and then use instruction_to_istate on the result: Function to decode an instruction and build the state to run it*) -(** PS made a placeholder in interp_inter_imp.lem, but it just uses decode_to_istate and throws away the istate; surely it's easy to just do what's necessary to get the instruction. This sort-of works, but it crashes on ioid 10 after 167 steps - maybe instruction_to_istate (which I wasn't using directly before) isn't quite right? *) -val decode_to_instruction : context -> maybe (list (reg_name * register_value))-> opcode -> instruction_or_decode_error - -(*Function to generate the state to run from an instruction form; is always an Instr*) -val instruction_to_istate : context -> instruction -> instruction_state (*i_state_or_error*) - -(* Slice a register value into a smaller vector, starting at first number (wrt the indices of the register value, not raw positions in its list of bits) and going to second (inclusive) according to order. *) -val slice_reg_value : register_value -> nat -> nat -> register_value -(*Create a new register value where the contents of nat to nat are replaced by the second register_value *) -val update_reg_value_slice : reg_name -> register_value -> nat -> nat -> register_value -> register_value - - -(* Big step of the interpreter, to the next request for an external action *) -(* When interp_mode has eager_eval false, interpreter is (close to) small step *) -val interp : interp_mode -> instruction_state -> outcome - -(* Run the interpreter without external interaction, feeding in Unknown on all reads -except for those register values provided *) -val interp_exhaustive : maybe (list (reg_name * register_value)) -> instruction_state -> list event - -(* As above, but will request register reads: outcome will only be rreg, done, or error *) -val rr_interp_exhaustive : interp_mode -> instruction_state -> list event -> (outcome * (list event)) - -val translate_address : - context -> end_flag -> string -> maybe (list (reg_name * register_value)) -> address - -> maybe address * maybe (list event) - - -val instruction_analysis : - context -> end_flag -> string -> (string -> (nat * nat * direction * (nat * nat))) - -> maybe (list (reg_name * register_value)) -> instruction -> (list reg_name * list reg_name * list reg_name * list nia * dia * instruction_kind) - - -val initial_outcome_s_of_instruction : (instruction_state -> unit -> (string * string)) -> context -> interp_mode -> instruction -> Sail_impl_base.outcome_s unit - diff --git a/src/lem_interp/0.11/interp_lib.lem b/src/lem_interp/0.11/interp_lib.lem deleted file mode 100644 index e55fc175..00000000 --- a/src/lem_interp/0.11/interp_lib.lem +++ /dev/null @@ -1,1111 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Pervasives -open import Interp_utilities -open import Interp -open import Interp_ast -(* For failwith for error reporting while debugging; and for fromJust when we know it's not Nothing *) -import Assert_extra Maybe_extra -open import Num -import Num_extra -open import List -open import Word -open import Bool - -type signed = Unsigned | Signed - -val debug_print : string -> unit -declare ocaml target_rep function debug_print s = `Printf.eprintf` "%s" s - -let print s = let _ = debug_print (string_of_value s) in V_lit(L_aux L_unit Unknown) - -let hardware_mod (a: integer) (b:integer) : integer = - if a < 0 && b < 0 - then (abs a) mod (abs b) - else if (a < 0 && b >= 0) - then (a mod b) - b - else a mod b - -(* There are different possible answers for integer divide regarding -rounding behaviour on negative operands. Positive operands always -round down so derive the one we want (trucation towards zero) from -that *) -let hardware_quot (a:integer) (b:integer) : integer = - let q = (abs a) / (abs b) in - if ((a<0) = (b<0)) then - q (* same sign -- result positive *) - else - ~q (* different sign -- result negative *) - -let (max_64u : integer) = integerFromNat ((natPow 2 64) - 1) -let (max_64 : integer) = integerFromNat ((natPow 2 63) - 1) -let (min_64 : integer) = integerNegate (integerFromNat (natPow 2 63)) -let (max_32u : integer) = integerFromNat (natPow 2 32) (*4294967295*) -let (max_32 : integer) = integerFromNat ((natPow 2 31) - 1) (*2147483647*) -let (min_32 : integer) = integerNegate (integerFromNat (natPow 2 31)) (*2147483648*) -let (max_8 : integer) = (integerFromNat 127) -let (min_8 : integer) = (integerFromNat 0) - (integerFromNat 128) -let (max_5 : integer) = (integerFromNat 31) - -val get_max_representable_in : signed -> nat -> integer -let get_max_representable_in sign n = - match (sign, n) with - | (Signed, 64) -> max_64 - | (Unsigned, 64) -> max_64u - | (Signed, 32) -> max_32 - | (Unsigned, 32) -> max_32u - | (Signed, 8) -> max_8 - | (Unsigned, 5) -> max_5 - | (Signed, _) -> 2**(n -1) - 1 - | (Unsigned, _) -> 2**n - 1 - end - -val get_min_representable_in : signed -> nat -> integer -let get_min_representable_in sign n = - match (sign, n) with - | (Unsigned, _) -> 0 - | (Signed, 64) -> min_64 - | (Signed, 32) -> min_32 - | (Signed, 8) -> min_8 - | (Signed, _) -> 0-(2**(n-1)) - end - -let ignore_sail x = V_lit (L_aux L_unit Unknown) ;; - -let compose f g x = f (V_tuple [g x]) ;; - -let zeroi = integerFromNat 0 -let onei = integerFromNat 1 -let twoi = integerFromNat 2 - -let is_unknown v = match detaint v with - | V_unknown -> true - | _ -> false -end - -let is_undef v = match detaint v with - | V_lit (L_aux L_undef _) -> true - | _ -> false -end - -let has_unknown v = match detaint v with - | V_vector _ _ vs -> List.any is_unknown vs - | V_unknown -> true - | _ -> false -end - -let has_undef v = match detaint v with - | V_vector _ _ vs -> List.any is_undef vs - | _ -> Assert_extra.failwith ("has_undef given non-vector " ^ (string_of_value v)) -end - -let rec sparse_walker update ni processed_length length ls df = - if processed_length = length - then [] - else match ls with - | [] -> replicate (length - processed_length) df - | (i,v)::ls -> - if ni = i - then v::(sparse_walker update (update ni) (processed_length + 1) length ls df) - else df::(sparse_walker update (update ni) (processed_length + 1) length ((i,v)::ls) df) -end - -let fill_in_sparse v = - retaint v (match detaint v with - | V_vector_sparse first length dir ls df -> - V_vector first dir - (sparse_walker - (if is_inc(dir) then (fun (x: nat) -> x + 1) else (fun (x: nat) -> x - 1)) first 0 length ls df) - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith ("fill_in_sparse given non-vector " ^ (string_of_value v)) - end) - -let is_one v = - retaint v - match detaint v with - | V_lit (L_aux (L_num n) lb) -> V_lit (L_aux (if n=1 then L_one else L_zero) lb) - | V_lit (L_aux b lb) -> V_lit (L_aux (if b = L_one then L_one else L_zero) lb) - | V_unknown -> v - | _ -> Assert_extra.failwith ("is_one given non-vector " ^ (string_of_value v)) -end ;; - -let rec most_significant v = - retaint v - match detaint v with - | V_vector _ _ (v::vs) -> v - | V_vector_sparse _ _ _ _ _ -> most_significant (fill_in_sparse v) - | V_lit (L_aux L_one _) -> v - | V_lit (L_aux L_zero _) -> v - | V_lit (L_aux (L_num n) lt) -> - if n = 1 - then V_lit (L_aux L_one lt) - else if n = 0 - then V_lit (L_aux L_zero lt) - else Assert_extra.failwith ("most_significant given non-vector " ^ (string_of_value v)) - | V_lit (L_aux L_undef _) -> v - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith ("most_significant given non-vector " ^ (string_of_value v)) -end;; - -let lt_range v = - let lr_helper v1 v2 = match (v1,v2) with - | (V_lit (L_aux (L_num l1) lr),V_lit (L_aux (L_num l2) ll)) -> - if l1 < l2 - then V_lit (L_aux L_one Unknown) - else V_lit (L_aux L_zero Unknown) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> - Assert_extra.failwith ("lt_range given non-lit (" ^ (string_of_value v1) ^ ", " ^ (string_of_value v2) ^ ")") - end in - match v with - | (V_tuple[v1;v2]) -> - binary_taint lr_helper v1 v2 - | _ -> Assert_extra.failwith ("lt_range not given tuple of length two " ^ (string_of_value v)) -end - -let bit_to_bool b = match detaint b with - | V_lit (L_aux L_zero _) -> false - | V_lit (L_aux L_false _) -> false - | V_lit (L_aux L_one _) -> true - | V_lit (L_aux L_true _) -> true - | _ -> Assert_extra.failwith ("bit_to_bool given unexpected " ^ (string_of_value b)) - end ;; -let bool_to_bit b = match b with - false -> V_lit (L_aux L_zero Unknown) - | true -> V_lit (L_aux L_one Unknown) - end ;; - -let bitwise_not_bit v = - let lit_not (L_aux l loc) = match l with - | L_zero -> (V_lit (L_aux L_one loc)) - | L_false -> (V_lit (L_aux L_one loc)) - | L_one -> (V_lit (L_aux L_zero loc)) - | L_true -> (V_lit (L_aux L_zero loc)) - | L_undef -> (V_lit (L_aux L_undef loc)) - | _ -> Assert_extra.failwith ("bitwise_not_bit given unexpected " ^ (string_of_value v)) end in - retaint v (match detaint v with - | V_lit lit -> lit_not lit - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith ("bitwise_not_bit given unexpected " ^ (string_of_value v)) - end) - -let rec bitwise_not v = - retaint v (match detaint v with - | V_vector idx inc v -> - V_vector idx inc (List.map bitwise_not_bit v) - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith ("bitwise_not given unexpected " ^ (string_of_value v)) - end) - -let rec bitwise_binop_bit op op_s v = - let b_b_b_help x y = match (x,y) with - | (V_vector _ _ [b],y) -> bitwise_binop_bit op op_s (V_tuple [b; y]) - | (_,V_vector _ _ [b]) -> bitwise_binop_bit op op_s (V_tuple [x; b]) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_lit (L_aux L_undef li), v) -> - (match op_s with | "|" -> y | "&" -> x | "^" -> y | _ -> x end) - | (v,V_lit (L_aux L_undef li)) -> - (match op_s with | "|" -> x | "&" -> y | "^" -> y | _ -> y end) - | _ -> bool_to_bit (op (bit_to_bool x) (bit_to_bool y)) end in - match v with - | (V_tuple [x; y]) -> binary_taint b_b_b_help x y - | _ -> Assert_extra.failwith ("bitwise_binop_bit not given tuple of length 2 " ^ (string_of_value v)) -end - -let rec bitwise_binop op op_s v = - let b_b_help v1 v2 = - match (v1,v2) with - | (V_vector idx inc v, V_vector idx' inc' v') -> - (* typechecker ensures inc = inc' and length v = length v' *) - V_vector idx inc (List.map (fun (x,y) -> (bitwise_binop_bit op op_s (V_tuple[x; y]))) (List.zip v v')) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> Assert_extra.failwith ("bitwise_binop given unexpected " ^ (string_of_value v)) end in - match v with - | (V_tuple [v1;v2]) -> binary_taint b_b_help v1 v2 - | _ -> Assert_extra.failwith ("bitwise_binop not given tuple of length 2 " ^ (string_of_value v)) -end - -(* BitSeq expects LSB first. - * By convention, MSB is on the left, so increasing = Big-Endian (MSB0), - * hence MSB first. - * http://en.wikipedia.org/wiki/Bit_numbering *) -let to_num signed v = - retaint v - (match detaint v with - | (V_vector idx inc l) -> - if has_unknown v then V_unknown else if l=[] then V_unknown - else if has_undef v then V_lit (L_aux L_undef Unknown) - else - (* Word library in Lem expects bitseq with LSB first *) - let l = reverse l in - (* Make sure the last bit is a zero to force unsigned numbers *) - let l = (match signed with | Signed -> l | Unsigned -> l ++ [V_lit (L_aux L_zero Unknown)] end) in - V_lit(L_aux (L_num(integerFromBitSeq (Maybe_extra.fromJust (bitSeqFromBoolList (map bit_to_bool l))))) Unknown) - | V_unknown -> V_unknown - | V_lit (L_aux L_undef _) -> v - | V_lit (L_aux L_zero l) -> V_lit (L_aux (L_num 0) l) - | V_lit (L_aux L_one l) -> V_lit (L_aux (L_num 1) l) - | _ -> Assert_extra.failwith ("to_num given unexpected " ^ (string_of_value v)) - end) - -let to_vec_inc v = - let fail () = Assert_extra.failwith ("to_vec_inc given unexpected " ^ (string_of_value v)) in - let tv_help v1 v2 = - match (v1,v2) with - | (V_lit(L_aux (L_num len) _), (V_lit(L_aux (L_num n) ln))) -> - let l = if len < 0 then [] - else boolListFrombitSeq (natFromInteger len) (bitSeqFromInteger Nothing n) in - V_vector 0 IInc (map bool_to_bit (reverse l)) - | ((V_lit(L_aux (L_num n) ln)),V_unknown) -> - V_vector 0 IInc (List.replicate (if n < 0 then 0 else (natFromInteger n)) V_unknown) - | ((V_lit(L_aux (L_num n) ln)),(V_lit (L_aux L_undef _))) -> - V_vector 0 IInc (List.replicate (natFromInteger n) v2) - | (_,V_unknown) -> V_unknown - | (V_unknown,_) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple[v1;v2]) -> binary_taint tv_help v1 v2 - | _ -> fail () -end - -let to_vec_dec v = - let fail () = Assert_extra.failwith ("to_vec_dec parameters were " ^ (string_of_value v)) in - let tv_fun v1 v2 = - match (v1,v2) with - | (V_lit(L_aux (L_num len) _), (V_lit(L_aux (L_num n) ln))) -> - let len = if len < 0 then 0 else natFromInteger len in - let l = boolListFrombitSeq len (bitSeqFromInteger Nothing n) in - V_vector (len - 1) IDec (map bool_to_bit (reverse l)) - | ((V_lit(L_aux (L_num n) ln)),V_unknown) -> - let n = if n < 0 then 0 else natFromInteger n in - V_vector (if n=0 then 0 else (n-1)) IDec (List.replicate n V_unknown) - | ((V_lit(L_aux (L_num n) ln)),(V_lit (L_aux L_undef _))) -> - let n = if n < 0 then 0 else natFromInteger n in - V_vector (if n = 0 then 0 else (n-1)) IDec (List.replicate n v2) - | (_,V_unknown) -> V_unknown - | (V_unknown,_) -> V_unknown - | _ -> fail () - end in - match v with - | V_tuple([v1;v2]) -> binary_taint tv_fun v1 v2 - | _ -> fail() -end - - -let rec to_vec_inc_undef v1 = - retaint v1 - match detaint v1 with - | V_lit(L_aux (L_num len) _) -> - let len = if len < 0 then 0 else natFromInteger len in - V_vector 0 IInc (List.replicate len (V_lit (L_aux L_undef Unknown))) - | _ -> V_unknown -end - -let rec to_vec_dec_undef v1 = - retaint v1 - match detaint v1 with - | V_lit(L_aux (L_num len) _) -> - let len = if len < 0 then 0 else natFromInteger len in - V_vector (len - 1) IDec (List.replicate len (V_lit (L_aux L_undef Unknown))) - | _ -> V_unknown -end - -let to_vec ord len n = - if is_inc(ord) - then to_vec_inc (V_tuple ([V_lit(L_aux (L_num len) Interp_ast.Unknown); n])) - else to_vec_dec (V_tuple ([V_lit(L_aux (L_num len) Interp_ast.Unknown); n])) -;; - -let exts direction v = - let exts_help v1 v = match (v1,v) with - | (V_lit(L_aux (L_num len) _), V_vector _ inc _)-> to_vec inc len (to_num Signed v) - | (V_lit(L_aux (L_num len) _), V_unknown) -> to_vec direction len V_unknown - | (V_unknown,_) -> V_unknown - | _ -> Assert_extra.failwith ("exts given unexpected " ^ (string_of_value v)) - end in - match v with - | (V_tuple[v1;v]) -> binary_taint exts_help v1 v - | _ -> Assert_extra.failwith ("exts not given tuple of length 2 " ^ (string_of_value v)) -end - -let extz direction v = - let extz_help v1 v = match (v1,v) with - | (V_lit(L_aux (L_num len) _), V_vector _ inc _)-> to_vec inc len (to_num Unsigned v) - | (V_lit(L_aux (L_num len) _), V_unknown) -> to_vec direction len V_unknown - | (V_unknown,_) -> V_unknown - | _ -> Assert_extra.failwith ("extx given unexpected " ^ (string_of_value v)) - end in - match v with - | (V_tuple[v1;v]) -> binary_taint extz_help v1 v - | _ -> Assert_extra.failwith ("extz not given tuple of length 2 " ^ (string_of_value v)) -end - -let eq v = match v with - | (V_tuple [x; y]) -> - let combo = binary_taint (fun v _ -> v) x y in - retaint combo - (if has_unknown x || has_unknown y - then V_unknown - else (V_lit (L_aux (if ((detaint x) = (detaint y)) then L_one else L_zero) Unknown))) - | _ -> Assert_extra.failwith ("eq not given tuple of length 2 " ^ (string_of_value v)) -end - -let eq_vec v = - let eq_vec_help v1 v2 = match (v1,v2) with - | ((V_vector _ _ c1s),(V_vector _ _ c2s)) -> - if (List.length c1s = List.length c2s) && - List.listEqualBy - (fun v1 v2 -> match eq (V_tuple [v1; v2]) with V_lit (L_aux L_one _) -> true | _ -> false end) c1s c2s then - V_lit (L_aux L_one Unknown) - else if has_unknown v1 || has_unknown v2 - then V_unknown - else V_lit (L_aux L_zero Unknown) - | (V_unknown, _) -> V_unknown - | (_, V_unknown) -> V_unknown - | (V_vector _ _ [c1], _) -> eq (V_tuple [c1; v2]) - | (_, V_vector _ _ [c2]) -> eq (V_tuple [v1; c2]) - | (V_lit _, V_lit _) -> eq (V_tuple [v1;v2]) (*Vectors of one bit return one bit; we need coercion to match*) - | _ -> Assert_extra.failwith ("eq_vec not given two vectors, given instead " ^ (string_of_value v)) end in - match v with - | (V_tuple [v1; v2]) -> binary_taint eq_vec_help v1 v2 - | _ -> Assert_extra.failwith ("eq_vec not given tuple of length 2 " ^ (string_of_value v)) -end - -let eq_vec_range v = match v with - | (V_tuple [v; r]) -> eq (V_tuple [to_num Unsigned v; r]) - | _ -> Assert_extra.failwith ("eq_vec_range not given tuple of length 2 " ^ (string_of_value v)) -end -let eq_range_vec v = match v with - | (V_tuple [r; v]) -> eq (V_tuple [r; to_num Unsigned v]) - | _ -> Assert_extra.failwith ("eq_range_vec not given tuple of length 2 " ^ (string_of_value v)) -end -(*let eq_vec_vec v = match v with - | (V_tuple [v;v2]) -> eq (V_tuple [to_num Signed v; to_num Signed v2]) - | _ -> Assert_extra.failwith ("eq_vec_vec not given tuple of length 2 " ^ (string_of_value v)) -end*) - -let rec neg v = retaint v (match detaint v with - | V_lit (L_aux arg la) -> - V_lit (L_aux (match arg with - | L_one -> L_zero - | L_zero -> L_one - | _ -> Assert_extra.failwith ("neg given unexpected " ^ (string_of_value v)) end) la) - | V_unknown -> V_unknown - | V_tuple [v] -> neg v - | _ -> Assert_extra.failwith ("neg given unexpected " ^ (string_of_value v)) -end) - -let neq = compose neg eq ;; - -let neq_vec = compose neg eq_vec -let neq_vec_range = compose neg eq_vec_range -let neq_range_vec = compose neg eq_range_vec - -let rec v_abs v = retaint v (match detaint v with - | V_lit (L_aux arg la) -> - V_lit (L_aux (match arg with - | L_num n -> if n < 0 then L_num (n * (0 - 1)) else L_num n - | _ -> Assert_extra.failwith ("abs given unexpected " ^ (string_of_value v)) end) la) - | V_unknown -> V_unknown - | V_tuple [v] -> v_abs v - | _ -> Assert_extra.failwith ("abs given unexpected " ^ (string_of_value v)) end) - -let arith_op op v = - let fail () = Assert_extra.failwith ("arith_op given unexpected " ^ (string_of_value v)) in - let arith_op_help vl vr = - match (vl,vr) with - | (V_lit(L_aux (L_num x) lx), V_lit(L_aux (L_num y) ly)) -> V_lit(L_aux (L_num (op x y)) lx) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_lit (L_aux L_undef lx),_) -> vl - | (_, (V_lit (L_aux L_undef ly))) -> vr - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_op_help vl vr - | _ -> fail () -end -let arith_op_vec op sign size v = - let fail () = Assert_extra.failwith ("arith_op_vec given unexpected " ^ (string_of_value v)) in - let arith_op_help vl vr = - match (vl,vr) with - | ((V_vector b ord cs as l1),(V_vector _ _ _ as l2)) -> - let (l1',l2') = (to_num sign l1,to_num sign l2) in - let n = arith_op op (V_tuple [l1';l2']) in - to_vec ord (integerFromNat ((List.length cs) * size)) n - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_op_help vl vr - | _ -> fail () -end -let arith_op_vec_vec_range op sign v = - let fail () = Assert_extra.failwith ("arith_op_vec_vec_range given unexpected " ^ (string_of_value v)) in - let arith_op_help vl vr = - match (vl,vr) with - | (V_vector _ _ _,V_vector _ _ _ ) -> - let (l1,l2) = (to_num sign vl,to_num sign vr) in - arith_op op (V_tuple [l1;l2]) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_op_help vl vr - | _ -> fail () -end -let arith_op_overflow_vec op over_typ sign size v = - let fail () = Assert_extra.failwith ("arith_op_overflow_vec given unexpected " ^ (string_of_value v)) in - let overflow_help vl vr = - match (vl,vr) with - | (V_vector b ord cs1,V_vector _ _ cs2) -> - let len = List.length cs1 in - let act_size = len * size in - let (is_l1_unknown,is_l2_unknown) = ((has_unknown vl), (has_unknown vr)) in - if is_l1_unknown || is_l2_unknown - then (V_tuple [ (to_vec ord (integerFromNat act_size) V_unknown);V_unknown;V_unknown]) - else - let (l1_sign,l2_sign) = (to_num sign vl,to_num sign vr) in - let (l1_unsign,l2_unsign) = (to_num Unsigned vl,to_num Unsigned vr) in - let n = arith_op op (V_tuple [l1_sign;l2_sign]) in - let n_unsign = arith_op op (V_tuple[l1_unsign;l2_unsign]) in - let correct_size_num = to_vec ord (integerFromNat act_size) n in - let one_more_size_u = to_vec ord (integerFromNat (act_size +1)) n_unsign in - let overflow = (match n with - | V_lit (L_aux (L_num n') ln) -> - if (n' <= (get_max_representable_in sign len)) && - (n' >= (get_min_representable_in sign len)) - then V_lit (L_aux L_zero ln) - else V_lit (L_aux L_one ln) - | _ -> Assert_extra.failwith ("overflow arith_op returned " ^ (string_of_value v)) end) in - let out_num = to_num sign correct_size_num in - let c_out = - match detaint one_more_size_u with - | V_vector _ _ (b::bits) -> b - | v -> Assert_extra.failwith ("to_vec returned " ^ (string_of_value v)) end in - V_tuple [correct_size_num;overflow;c_out] - | (V_unknown,_) -> V_tuple [V_unknown;V_unknown;V_unknown] - | (_,V_unknown) -> V_tuple [V_unknown;V_unknown;V_unknown] - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint overflow_help vl vr - | _ -> fail () -end -let arith_op_overflow_vec_bit op sign size v = - let fail () = Assert_extra.failwith ("arith_op_overflow_vec_bit given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = - match (vl,vr) with - | (V_vector b ord cs, V_lit (L_aux bit li)) -> - let act_size = (List.length cs) * size in - let is_v_unknown = has_unknown vl in - if is_v_unknown - then V_tuple [(to_vec ord (integerFromNat act_size) V_unknown);V_unknown;V_unknown] - else - let l1' = to_num sign vl in - let l1_u = to_num Unsigned vl in - let (n,nu,changed) = match bit with - | L_one -> (arith_op op (V_tuple [l1';(V_lit (L_aux (L_num 1) li))]), - arith_op op (V_tuple [l1_u;(V_lit (L_aux (L_num 1) li))]), true) - | L_zero -> (l1',l1_u,false) - | _ -> Assert_extra.failwith "arith_op_overflow_vec bit given non bit" end in - let correct_size_num = to_vec ord (integerFromNat act_size) n in - let one_larger = to_vec ord (integerFromNat (act_size +1)) nu in - let overflow = if changed - then retaint n (match detaint n with - | V_lit (L_aux (L_num n') ln) -> - if (n' <= (get_max_representable_in sign act_size)) && - (n' >= (get_min_representable_in sign act_size)) - then V_lit (L_aux L_zero ln) - else V_lit (L_aux L_one ln) - | _ -> Assert_extra.failwith "to_num returned non num" end) - else V_lit (L_aux L_zero Unknown) in - let carry_out = (match detaint one_larger with - | V_vector _ _ (c::rst) -> c - | _ -> Assert_extra.failwith "one_larger vector returned non vector" end) in - V_tuple [correct_size_num;overflow;carry_out] - | (V_unknown,_) -> V_tuple [V_unknown;V_unknown;V_unknown] - | (_,V_unknown) -> V_tuple [V_unknown;V_unknown;V_unknown] - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_range_vec op sign size v = - let fail () = Assert_extra.failwith ("arith_op_range_vec given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (n, V_vector _ ord cs) -> - arith_op_vec op sign size (V_tuple [(to_vec ord (integerFromNat (List.length cs)) n);vr]) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_vec_range op sign size v = - let fail () = Assert_extra.failwith ("arith_op_vec_range given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_vector _ ord cs,n) -> - arith_op_vec op sign size (V_tuple [vl;(to_vec ord (integerFromNat (List.length cs)) n)]) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_range_vec_range op sign v = - let fail () = Assert_extra.failwith ("arith_op_range_vec_range given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (n,V_vector _ ord _) -> - arith_op op (V_tuple [n;(to_num Unsigned vr)]) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_vec_range_range op sign v = - let fail () = Assert_extra.failwith ("arith_op_vec_range_range given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_vector _ ord _ ,n) -> - arith_op op (V_tuple [(to_num sign vl);n]) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_vec_bit op sign size v = - let fail () = Assert_extra.failwith ("arith_op_vec_bit given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = - match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_vector _ ord cs,V_lit (L_aux bit _)) -> - let l1' = to_num sign vl in - let n = arith_op op (V_tuple - [l1'; - V_lit - (L_aux (L_num (match bit with | L_one -> 1 | _ -> 0 end)) Unknown)]) - in - to_vec ord (integerFromNat ((List.length cs) * size)) n - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_no0 op v = - let fail () = Assert_extra.failwith ("arith_op_no0 given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = - match (vl,vr) with - | (V_lit(L_aux (L_num x) lx), V_lit(L_aux (L_num y) ly)) -> - if y = 0 - then V_lit (L_aux L_undef ly) - else V_lit(L_aux (L_num (op x y)) lx) - | (V_lit (L_aux L_undef lx),_) -> vl - | (_, (V_lit (L_aux L_undef ly))) -> vr - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_vec_no0 op op_s sign size v = - let fail () = Assert_extra.failwith ("arith_op_vec_no0 given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = - match (vl,vr) with - | (V_vector b ord cs, V_vector _ _ _) -> - let act_size = (List.length cs) * size in - let (is_l1_unknown,is_l2_unknown) = ((has_unknown vl), (has_unknown vr)) in - let (l1',l2') = (if is_l1_unknown then V_unknown else (to_num sign vl), - if is_l2_unknown then V_unknown else (to_num sign vr)) in - let n = if is_l1_unknown || is_l2_unknown then V_unknown else arith_op op (V_tuple [l1';l2']) in - let representable = - match detaint n with - | V_lit (L_aux (L_num n') ln) -> - ((n' <= (get_max_representable_in sign act_size)) && (n' >= (get_min_representable_in sign act_size))) - | _ -> true end in - if representable - then to_vec ord (integerFromNat act_size) n - else to_vec ord (integerFromNat act_size) (V_lit (L_aux L_undef Unknown)) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let arith_op_overflow_vec_no0 op op_s sign size v = - let fail () = Assert_extra.failwith ("arith_op_overflow_vec_no0 given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = - match (vl,vr) with - | (V_vector b ord cs, V_vector _ _ cs2) -> - let rep_size = (List.length cs2) * size in - let act_size = (List.length cs) * size in - let (is_l1_unknown,is_l2_unknown) = ((has_unknown vl), (has_unknown vr)) in - if is_l1_unknown || is_l2_unknown - then V_tuple [to_vec ord (integerFromNat act_size) V_unknown;V_unknown;V_unknown] - else - let (l1',l2') = ((to_num sign vl),(to_num sign vr)) in - let (l1_u,l2_u) = (to_num Unsigned vl,to_num Unsigned vr) in - let n = arith_op op (V_tuple [l1';l2']) in - let n_u = arith_op op (V_tuple [l1_u;l2_u]) in - let representable = - match detaint n with - | V_lit (L_aux (L_num n') ln) -> - ((n' <= (get_max_representable_in sign rep_size)) && (n' >= (get_min_representable_in sign rep_size))) - | _ -> true end in - let (correct_size_num,one_more) = - if representable then (to_vec ord (integerFromNat act_size) n,to_vec ord (integerFromNat (act_size+1)) n_u) - else let udef = V_lit (L_aux L_undef Unknown) in - (to_vec ord (integerFromNat act_size) udef, to_vec ord (integerFromNat (act_size +1)) udef) in - let overflow = if representable then V_lit (L_aux L_zero Unknown) else V_lit (L_aux L_one Unknown) in - let carry = match one_more with - | V_vector _ _ (b::bits) -> b - | _ -> Assert_extra.failwith "one_more returned non-vector" end in - V_tuple [correct_size_num;overflow;carry] - | (V_unknown,_) -> V_tuple [V_unknown;V_unknown;V_unknown] - | (_,V_unknown) -> V_tuple [V_unknown;V_unknown;V_unknown] - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail() -end - -let arith_op_vec_range_no0 op op_s sign size v = - let fail () = Assert_extra.failwith ("arith_op_vec_range_no0 given unexpected " ^ (string_of_value v)) in - let arith_help vl vr = - match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_vector _ ord cs,n) -> - arith_op_vec_no0 op op_s sign size (V_tuple [vl;(to_vec ord (integerFromNat (List.length cs)) n)]) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_help vl vr - | _ -> fail () -end - -let rec shift_op_vec op v = - let fail () = Assert_extra.failwith ("shift_op_vec given unexpected " ^ (string_of_value v)) in - let arith_op_help vl vr = - match (vl,vr) with - | (V_vector b ord cs,V_lit (L_aux (L_num n) _)) -> - let n = natFromInteger n in - (match op with - | "<<" -> - V_vector b ord - ((from_n_to_n n ((length cs) - 1) cs) ++(List.replicate n (V_lit (L_aux L_zero Unknown)))) - | ">>" -> - V_vector b ord - ((List.replicate n (V_lit (L_aux L_zero Unknown))) ++ (from_n_to_n 0 (((length cs) -1) - n) cs)) - | "<<<" -> - V_vector b ord - ((from_n_to_n n ((length cs) -1) cs) ++ (from_n_to_n 0 (n-1) cs)) - | _ -> Assert_extra.failwith "shift_op_vec given non-recognized op" end) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_lit (L_aux L_undef lx), _) -> V_lit (L_aux L_undef lx) - | (_, V_lit (L_aux L_undef ly)) -> V_lit (L_aux L_undef ly) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint arith_op_help vl vr - | _ -> fail () -end - -let compare_op op v = - let fail () = Assert_extra.failwith ("compare_op given unexpected " ^ (string_of_value v)) in - let comp_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_lit (L_aux L_undef lx), _) -> V_lit (L_aux L_undef lx) - | (_, V_lit (L_aux L_undef ly)) -> V_lit (L_aux L_undef ly) - | (V_lit(L_aux (L_num x) lx), V_lit(L_aux (L_num y) ly)) -> - if (op x y) - then V_lit(L_aux L_one lx) - else V_lit(L_aux L_zero lx) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint comp_help vl vr - | _ -> fail () -end - -let compare_op_vec op sign v = - let fail () = Assert_extra.failwith ("compare_op_vec given unexpected " ^ (string_of_value v)) in - let comp_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_vector _ _ _,V_vector _ _ _) -> - let (l1',l2') = (to_num sign vl, to_num sign vr) in - compare_op op (V_tuple[l1';l2']) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint comp_help vl vr - | _ -> fail () -end - -let compare_op_vec_range op sign v = - let fail () = Assert_extra.failwith ("compare_op_vec_range given unexpected " ^ (string_of_value v)) in - let comp_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> compare_op op (V_tuple[(to_num sign vl);vr]) - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint comp_help vl vr - | _ -> fail () -end - -let compare_op_range_vec op sign v = - let fail () = Assert_extra.failwith ("compare_op_range_vec given unexpected " ^ (string_of_value v)) in - let comp_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> compare_op op (V_tuple[vl;(to_num sign vr)]) - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint comp_help vl vr - | _ -> fail () -end - -let compare_op_vec_unsigned op v = - let fail () = Assert_extra.failwith ("compare_op_vec_unsigned given unexpected " ^ (string_of_value v)) in - let comp_help vl vr = match (vl,vr) with - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_vector _ _ _,V_vector _ _ _) -> - let (l1',l2') = (to_num Unsigned vl, to_num Unsigned vr) in - compare_op op (V_tuple[l1';l2']) - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint comp_help vl vr - | _ -> fail () -end - -let duplicate direction v = - let fail () = Assert_extra.failwith ("duplicate given unexpected " ^ (string_of_value v)) in - let dup_help vl vr = - match (vl,vr) with - | ((V_lit _ as v),(V_lit (L_aux (L_num n) _))) -> - V_vector 0 direction (List.replicate (natFromInteger n) v) - | (V_unknown,(V_lit (L_aux (L_num n) _))) -> - V_vector 0 direction (List.replicate (natFromInteger n) V_unknown) - | (V_unknown,_) -> V_unknown - | (_, V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint dup_help vl vr - | _ -> fail () -end - -let rec repeat_block_helper (n: integer) bits = - if n <= 0 - then [] - else bits ++ (repeat_block_helper (n-1) bits) - -let duplicate_bits v = - let fail () = Assert_extra.failwith ("duplicate_bits given unexpected " ^ (string_of_value v)) in - let dup_help vl vr = - match (vl,vr) with - | (V_vector start direction bits, (V_lit (L_aux (L_num n) _))) -> - let start : nat = if direction = IInc then 0 else ((natFromInteger n) * (List.length bits)) - 1 in - (V_vector start direction (repeat_block_helper n bits)) - | (_,V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint dup_help vl vr - | _ -> fail () -end - - -let rec vec_concat v = - let fail () = Assert_extra.failwith ("vec_concat given unexpected " ^ (string_of_value v)) in - let concat_help vl vr = - match (vl,vr) with - | (V_vector n d l, V_vector n' d' l') -> - (* XXX d = d' ? dropping n' ? *) - V_vector n d (l ++ l') - | (V_lit l, (V_vector n d l' as x)) -> vec_concat (V_tuple [litV_to_vec l d; x]) - | ((V_vector n d l' as x), V_lit l) -> vec_concat (V_tuple [x; litV_to_vec l d]) - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> fail () - end in - match v with - | (V_tuple [vl;vr]) -> binary_taint concat_help vl vr - | _ -> fail () -end - -let v_length v = retaint v (match detaint v with - | V_vector n d l -> V_lit (L_aux (L_num (integerFromNat (List.length l))) Unknown) - | V_unknown -> V_unknown - | _ -> Assert_extra.failwith ("length given unexpected " ^ (string_of_value v)) end) - -let min v = retaint v (match detaint v with - | V_tuple [v1;v2] -> - (match (detaint v1,detaint v2) with - | (V_lit (L_aux (L_num l1) _), V_lit (L_aux (L_num l2) _)) -> - if l1 < l2 - then retaint v2 v1 - else retaint v1 v2 - | (V_unknown,_) -> V_unknown - | (_,V_unknown) -> V_unknown - | (V_lit l1,_) -> Assert_extra.failwith ("Second argument to min not a number " ^ (string_of_value v2)) - | (_,V_lit l2) -> Assert_extra.failwith ("First argument to min not a number " ^ (string_of_value v1)) - | _ -> - Assert_extra.failwith ("min given unexpected " ^ (string_of_value v1) ^ " and " ^ (string_of_value v2)) end) - | _ -> Assert_extra.failwith ("min given unexpected " ^ (string_of_value v)) end) - -let max v = retaint v (match detaint v with - | (V_tuple [(V_lit (L_aux (L_num l1) _) as v1); (V_lit (L_aux (L_num l2) _) as v2)]) -> - if l1 > l2 - then v1 - else v2 - | V_tuple [V_unknown; V_unknown] -> V_unknown - | _ -> Assert_extra.failwith ("max given unexpected " ^ (string_of_value v)) end) - - -let mask direction v = - let fail () = Assert_extra.failwith ("shift_op_vec given unexpected " ^ (string_of_value v)) in - match v with - | (V_tuple [vsize;v]) -> - retaint v (match (detaint v,detaint vsize) with - | (V_vector s d l,V_lit (L_aux (L_num n) _)) -> - let n = natFromInteger n in - let current_size = List.length l in - V_vector (if is_inc(d) then 0 else (n-1)) d (drop (current_size - n) l) - | (V_unknown,V_lit (L_aux (L_num n) _)) -> - let nat_n = natFromInteger n in - let start_num = if is_inc(direction) then 0 else nat_n -1 in - V_vector start_num direction (List.replicate nat_n V_unknown) - | (_,V_unknown) -> V_unknown - | _ -> fail () end) -| _ -> fail () -end - -let s_append v = - let fail () = Assert_extra.failwith ("append given unexpected " ^ (string_of_value v)) in - match v with - | (V_tuple [l1;l2]) -> - retaint v (match (detaint l1,detaint l2) with - | (V_list vs1, V_list vs2) -> V_list (vs1++vs2) - | (V_unknown, _) -> V_unknown - | (_,V_unknown) -> V_unknown - | _ -> fail () end) - | _ -> fail () -end - -let library_functions direction = [ - ("ignore", ignore_sail); - ("append", s_append); - ("length", v_length); - ("add", arith_op (+)); - ("add_vec", arith_op_vec (+) Unsigned 1); - ("add_vec_range", arith_op_vec_range (+) Unsigned 1); - ("add_vec_range_range", arith_op_vec_range_range (+) Unsigned); - ("add_range_vec", arith_op_range_vec (+) Unsigned 1); - ("add_range_vec_range", arith_op_range_vec_range (+) Unsigned); - ("add_vec_vec_range", arith_op_vec_vec_range (+) Unsigned); - ("add_vec_bit", arith_op_vec_bit (+) Unsigned 1); - ("add_overflow_vec", arith_op_overflow_vec (+) "+" Unsigned 1); - ("add_signed", arith_op (+)); - ("add_vec_signed", arith_op_vec (+) Signed 1); - ("add_vec_range_signed", arith_op_vec_range (+) Signed 1); - ("add_vec_range_range_signed", arith_op_vec_range_range (+) Signed); - ("add_range_vec_signed", arith_op_range_vec (+) Signed 1); - ("add_range_vec_range_signed", arith_op_range_vec_range (+) Signed); - ("add_vec_vec_range_signed", arith_op_vec_vec_range (+) Signed); - ("add_vec_bit_signed", arith_op_vec_bit (+) Signed 1); - ("add_overflow_vec_signed", arith_op_overflow_vec (+) "+" Signed 1); - ("add_overflow_vec_bit_signed", arith_op_overflow_vec_bit (+) Signed 1); - ("minus", arith_op (-)); - ("minus_vec", arith_op_vec (-) Unsigned 1); - ("minus_vec_range", arith_op_vec_range (-) Unsigned 1); - ("minus_range_vec", arith_op_range_vec (-) Unsigned 1); - ("minus_vec_range_range", arith_op_vec_range_range (-) Unsigned); - ("minus_range_vec_range", arith_op_range_vec_range (-) Unsigned); - ("minus_vec_bit", arith_op_vec_bit (-) Unsigned 1); - ("minus_overflow_vec", arith_op_overflow_vec (-) "+" Unsigned 1); - ("minus_overflow_vec_bit", arith_op_overflow_vec_bit (-) Unsigned 1); - ("minus_overflow_vec_signed", arith_op_overflow_vec (-) "+" Signed 1); - ("minus_overflow_vec_bit_signed", arith_op_overflow_vec_bit (-) Signed 1); - ("multiply", arith_op ( * )); - ("multiply_vec", arith_op_vec ( * ) Unsigned 2); - ("mult_range_vec", arith_op_range_vec ( * ) Unsigned 2); - ("mult_vec_range", arith_op_vec_range ( * ) Unsigned 2); - ("mult_overflow_vec", arith_op_overflow_vec ( * ) "*" Unsigned 2); - ("multiply_vec_signed", arith_op_vec ( * ) Signed 2); - ("mult_range_vec_signed", arith_op_range_vec ( * ) Signed 2); - ("mult_vec_range_signed", arith_op_vec_range ( * ) Signed 2); - ("mult_overflow_vec_signed", arith_op_overflow_vec ( * ) "*" Signed 2); - ("bitwise_leftshift", shift_op_vec "<<"); - ("bitwise_rightshift", shift_op_vec ">>"); - ("bitwise_rotate", shift_op_vec "<<<"); - ("modulo", arith_op_no0 (mod)); - ("mod_signed", arith_op_no0 hardware_mod); - ("mod_vec", arith_op_vec_no0 hardware_mod "mod" Unsigned 1); - ("mod_vec_range", arith_op_vec_range_no0 hardware_mod "mod" Unsigned 1); - ("mod_signed_vec", arith_op_vec_no0 hardware_mod "mod" Signed 1); - ("mod_signed_vec_range", arith_op_vec_range_no0 hardware_mod "mod" Signed 1); - ("quot", arith_op_no0 hardware_quot); - ("quot_signed", arith_op_no0 hardware_quot); - ("quot_vec", arith_op_vec_no0 hardware_quot "quot" Unsigned 1); - ("quot_overflow_vec", arith_op_overflow_vec_no0 hardware_quot "quot" Unsigned 1); - ("quot_vec_signed", arith_op_vec_no0 hardware_quot "quot" Signed 1); - ("quot_overflow_vec_signed", arith_op_overflow_vec_no0 hardware_quot "quot" Signed 1); - ("print", print); - ("power", arith_op power); - ("eq", eq); - ("eq_vec", eq_vec); - ("eq_vec_range", eq_vec_range); - ("eq_range_vec", eq_range_vec); - ("eq_bit", eq); - ("eq_range", eq); - ("neq", neq); - ("neq_vec", neq_vec); - ("neq_vec_range", neq_vec_range); - ("neq_range_vec", neq_range_vec); - ("neq_bit", neq); - ("neq_range", neq); - ("vec_concat", vec_concat); - ("is_one", is_one); - ("to_num", to_num Unsigned); - ("exts", exts direction); - ("extz", extz direction); - ("to_vec_inc", to_vec_inc); - ("to_vec_inc_undef", to_vec_inc_undef); - ("to_vec_dec", to_vec_dec); - ("to_vec_dec_undef", to_vec_dec_undef); - ("bitwise_not", bitwise_not); - ("bitwise_not_bit", bitwise_not_bit); - ("bitwise_and", bitwise_binop (&&) "&"); - ("bitwise_or", bitwise_binop (||) "|"); - ("bitwise_xor", bitwise_binop xor "^"); - ("bitwise_and_bit", bitwise_binop_bit (&&) "&"); - ("bitwise_or_bit", bitwise_binop_bit (||) "|"); - ("bitwise_xor_bit", bitwise_binop_bit xor "^"); - ("lt", compare_op (<)); - ("lt_signed", compare_op (<)); - ("gt", compare_op (>)); - ("lteq", compare_op (<=)); - ("gteq", compare_op (>=)); - ("lt_vec", compare_op_vec (<) Signed); - ("gt_vec", compare_op_vec (>) Signed); - ("lt_vec_range", compare_op_vec_range (<) Signed); - ("gt_vec_range", compare_op_vec_range (>) Signed); - ("lt_range_vec", compare_op_range_vec (<) Signed); - ("gt_range_vec", compare_op_range_vec (>) Signed); - ("lteq_vec_range", compare_op_vec_range (<=) Signed); - ("gteq_vec_range", compare_op_vec_range (>=) Signed); - ("lteq_range_vec", compare_op_range_vec (<=) Signed); - ("gteq_range_vec", compare_op_range_vec (>=) Signed); - ("lteq_vec", compare_op_vec (<=) Signed); - ("gteq_vec", compare_op_vec (>=) Signed); - ("lt_vec_signed", compare_op_vec (<) Signed); - ("gt_vec_signed", compare_op_vec (>) Signed); - ("lteq_vec_signed", compare_op_vec (<=) Signed); - ("gteq_vec_signed", compare_op_vec (>=) Signed); - ("lt_vec_unsigned", compare_op_vec (<) Unsigned); - ("gt_vec_unsigned", compare_op_vec (>) Unsigned); - ("lteq_vec_unsigned", compare_op_vec (<=) Unsigned); - ("gteq_vec_unsigned", compare_op_vec (>=) Unsigned); - ("signed", to_num Signed); - ("unsigned", to_num Unsigned); - ("ltu", compare_op_vec_unsigned (<)); - ("gtu", compare_op_vec_unsigned (>)); - ("duplicate", duplicate direction); - ("duplicate_bits", duplicate_bits); - ("mask", mask direction); - ("most_significant", most_significant); - ("min", min); - ("max", max); - ("abs", v_abs); -] ;; - -let eval_external name v = match List.lookup name (library_functions IInc) with - | Just f -> f v - | Nothing -> Assert_extra.failwith ("missing library function " ^ name) - end diff --git a/src/lem_interp/0.11/interp_utilities.lem b/src/lem_interp/0.11/interp_utilities.lem deleted file mode 100644 index 1e6c59ff..00000000 --- a/src/lem_interp/0.11/interp_utilities.lem +++ /dev/null @@ -1,212 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Interp_ast -open import Pervasives -open import Show_extra - -let rec power (a: integer) (b: integer) : integer = - if b <= 0 - then 1 - else a * (power a (b-1)) - -let foldr2 f x l l' = List.foldr (Tuple.uncurry f) x (List.zip l l') -let map2 f l l' = List.map (Tuple.uncurry f) (List.zip l l') - -let get_exp_l (E_aux e (l,annot)) = l - -val pure : effect -let pure = Effect_aux(Effect_set []) Unknown -let unit_t = Typ_aux(Typ_app (Id_aux (Id "unit") Unknown) []) Unknown - -let mk_typ_app str args = Typ_aux (Typ_app (Id_aux (Id str) Unknown) (List.map (fun aux -> Typ_arg_aux aux Unknown) args)) Unknown -let mk_typ_id str = Typ_aux (Typ_id (Id_aux (Id str) Unknown)) Unknown - -let mk_typ_var str = Typ_aux (Typ_var (Kid_aux (Var ("'" ^ str)) Unknown)) Unknown -let mk_typ_tup typs = Typ_aux (Typ_tup typs) Unknown - -let nconstant n = Nexp_aux (Nexp_constant n) Unknown - -(* Workaround Lem's inability to scrap my (type classes) boilerplate. - * Implementing only Eq, and only for literals - hopefully this will - * be enough, but we should in principle implement ordering for everything in - * Interp_ast *) - -val lit_eq: lit -> lit -> bool -let {ocaml;coq} lit_eq (L_aux left _) (L_aux right _) = - match (left, right) with - | (L_zero, L_zero) -> true - | (L_one, L_one) -> true - | (L_bin b, L_bin b') -> b = b' - | (L_hex h, L_hex h') -> h = h' - | (L_zero, L_num i) -> i = 0 - | (L_num i,L_zero) -> i = 0 - | (L_one, L_num i) -> i = 1 - | (L_num i, L_one) -> i = 1 - | (L_num n, L_num m) -> n = m - | (L_unit, L_unit) -> true - | (L_true, L_true) -> true - | (L_false, L_false) -> true - | (L_undef, L_undef) -> true - | (L_string s, L_string s') -> s = s' - | (_, _) -> false -end -let {isabelle;hol} lit_eq = unsafe_structural_equality - -let {ocaml;coq} lit_ineq n1 n2 = not (lit_eq n1 n2) -let {isabelle;hol} lit_ineq = unsafe_structural_inequality - -instance (Eq lit) - let (=) = lit_eq - let (<>) = lit_ineq -end - -let get_id id = match id with (Id_aux (Id s) _) -> s | (Id_aux (DeIid s) _ ) -> s end - -let rec {ocaml} list_to_string format sep lst = match lst with - | [] -> "" - | [last] -> format last - | one::rest -> (format one) ^ sep ^ (list_to_string format sep rest) -end -let ~{ocaml} list_to_string format sep list = "" - -val has_rmem_effect : list base_effect -> bool -val has_rmemt_effect : list base_effect -> bool -val has_barr_effect : list base_effect -> bool -val has_wmem_effect : list base_effect -> bool -val has_depend_effect : list base_effect -> bool -let rec has_effect which efcts = - match efcts with - | [] -> false - | (BE_aux e _)::efcts -> - match (which,e) with - | (BE_rreg,BE_rreg) -> true - | (BE_wreg,BE_wreg) -> true - | (BE_rmem,BE_rmem) -> true - | (BE_rmemt,BE_rmemt) -> true - | (BE_wmem,BE_wmem) -> true - | (BE_wmv,BE_wmv) -> true - | (BE_wmvt,BE_wmvt) -> true - | (BE_eamem,BE_eamem) -> true - | (BE_exmem,BE_exmem) -> true - | (BE_barr,BE_barr) -> true - | (BE_undef,BE_undef) -> true - | (BE_unspec,BE_unspec) -> true - | (BE_nondet,BE_nondet) -> true - | (BE_depend,BE_depend) -> true - | _ -> has_effect which efcts - end - end -let has_rmem_effect = has_effect BE_rmem -let has_rmemt_effect = has_effect BE_rmemt -let has_barr_effect = has_effect BE_barr -let has_wmem_effect = has_effect BE_wmem -let has_eamem_effect = has_effect BE_eamem -let has_exmem_effect = has_effect BE_exmem -let has_wmv_effect = has_effect BE_wmv -let has_wmvt_effect = has_effect BE_wmvt -let has_depend_effect = has_effect BE_depend - -let get_typ (TypSchm_aux (TypSchm_ts tq t) _) = t -let get_effects (Typ_aux t _) = - match t with - | Typ_fn a r (Effect_aux (Effect_set eff) _) -> eff - | _ -> [] - end - -let {ocaml} string_of_tag tag = match tag with - | Tag_empty -> "empty" - | Tag_global -> "global" - | Tag_ctor -> "ctor" - | Tag_extern (Just n) -> "extern " ^ n - | Tag_extern _ -> "extern" - | Tag_default -> "default" - | Tag_spec -> "spec" - | Tag_enum i -> "enum" - | Tag_alias -> "alias" -end -let ~{ocaml} string_of_tag tag = "" - -val find_type_def : defs tannot -> id -> maybe (type_def tannot) -val find_function : defs tannot -> id -> maybe (list (funcl tannot)) - -let get_funcls id (FD_aux (FD_function _ _ _ fcls) _) = - List.filter (fun (FCL_aux (FCL_Funcl name pexp) _) -> (get_id id) = (get_id name)) fcls - -let rec find_function (Defs defs) id = - match defs with - | [] -> Nothing - | def::defs -> - match def with - | DEF_fundef f -> match get_funcls id f with - | [] -> find_function (Defs defs) id - | funcs -> Just funcs end - | _ -> find_function (Defs defs) id - end end - - -let rec get_first_index_range (BF_aux i _) = match i with - | BF_single i -> (natFromInteger i) - | BF_range i j -> (natFromInteger i) - | BF_concat s _ -> get_first_index_range s -end - -let rec get_index_range_size (BF_aux i _) = match i with - | BF_single _ -> 1 - | BF_range i j -> (natFromInteger (abs (i-j))) + 1 - | BF_concat i j -> (get_index_range_size i) + (get_index_range_size j) -end - -let rec string_of_loc l = match l with - | Unknown -> "Unknown" - | Int s Nothing -> "Internal " ^ s - | Int s (Just l) -> "Internal " ^ s ^ " " ^ (string_of_loc l) - | Range file n1 n2 n3 n4 -> "File " ^ file ^ ": " ^ (show n1) ^ ": " ^ (show (n2:nat)) ^ ": " ^ (show (n3:nat)) ^ ": " ^ (show (n4:nat)) -end diff --git a/src/lem_interp/0.11/sail2_impl_base.lem b/src/lem_interp/0.11/sail2_impl_base.lem deleted file mode 100644 index f1cd9f2a..00000000 --- a/src/lem_interp/0.11/sail2_impl_base.lem +++ /dev/null @@ -1,1103 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Pervasives_extra -open import Sail2_instr_kinds - - -class ( EnumerationType 'a ) - val toNat : 'a -> nat -end - - -val enumeration_typeCompare : forall 'a. EnumerationType 'a => 'a -> 'a -> ordering -let ~{ocaml} enumeration_typeCompare e1 e2 = - compare (toNat e1) (toNat e2) -let inline {ocaml} enumeration_typeCompare = defaultCompare - - -default_instance forall 'a. EnumerationType 'a => (Ord 'a) - let compare = enumeration_typeCompare - let (<) r1 r2 = (enumeration_typeCompare r1 r2) = LT - let (<=) r1 r2 = (enumeration_typeCompare r1 r2) <> GT - let (>) r1 r2 = (enumeration_typeCompare r1 r2) = GT - let (>=) r1 r2 = (enumeration_typeCompare r1 r2) <> LT -end - - - -(* maybe isn't a member of type Ord - this should be in the Lem standard library*) -instance forall 'a. Ord 'a => (Ord (maybe 'a)) - let compare = maybeCompare compare - let (<) r1 r2 = (maybeCompare compare r1 r2) = LT - let (<=) r1 r2 = (maybeCompare compare r1 r2) <> GT - let (>) r1 r2 = (maybeCompare compare r1 r2) = GT - let (>=) r1 r2 = (maybeCompare compare r1 r2) <> LT -end - -type word8 = nat (* bounded at a byte, for when lem supports it*) - -type end_flag = - | E_big_endian - | E_little_endian - -type bit = - | Bitc_zero - | Bitc_one - -type bit_lifted = - | Bitl_zero - | Bitl_one - | Bitl_undef (* used for modelling h/w arch unspecified bits *) - | Bitl_unknown (* used for interpreter analysis exhaustive execution *) - -type direction = - | D_increasing - | D_decreasing - -let dir_of_bool is_inc = if is_inc then D_increasing else D_decreasing -let bool_of_dir = function - | D_increasing -> true - | D_decreasing -> false - end - -(* at some point this should probably not mention bit_lifted anymore *) -type register_value = <| - rv_bits: list bit_lifted (* MSB first, smallest index number *); - rv_dir: direction; - rv_start: nat ; - rv_start_internal: nat; - (*when dir is increasing, rv_start = rv_start_internal. - Otherwise, tells interpreter how to reconstruct a proper decreasing value*) - |> - -type byte_lifted = Byte_lifted of list bit_lifted (* of length 8 *) (*MSB first everywhere*) - -type instruction_field_value = list bit - -type byte = Byte of list bit (* of length 8 *) (*MSB first everywhere*) - -type address_lifted = Address_lifted of list byte_lifted (* of length 8 for 64bit machines*) * maybe integer -(* for both values of end_flag, MSBy first *) - -type memory_byte = byte_lifted (* of length 8 *) (*MSB first everywhere*) - -type memory_value = list memory_byte -(* the list is of length >=1 *) -(* the head of the list is the byte stored at the lowest address; -when calling a Sail function with a wmv effect, the least significant 8 -bits of the bit vector passed to the function will be interpreted as -the lowest address byte; similarly, when calling a Sail function with -rmem effect, the lowest address byte will be placed in the least -significant 8 bits of the bit vector returned by the function; this -behaviour is consistent with little-endian. *) - - -(* not sure which of these is more handy yet *) -type address = Address of list byte (* of length 8 *) * integer -(* type address = Address of integer *) - -type opcode = Opcode of list byte (* of length 4 *) - -(** typeclass instantiations *) - -instance (EnumerationType bit) - let toNat = function - | Bitc_zero -> 0 - | Bitc_one -> 1 - end -end - -instance (EnumerationType bit_lifted) - let toNat = function - | Bitl_zero -> 0 - | Bitl_one -> 1 - | Bitl_undef -> 2 - | Bitl_unknown -> 3 - end -end - -let ~{ocaml} byte_liftedCompare (Byte_lifted b1) (Byte_lifted b2) = compare b1 b2 -let inline {ocaml} byte_liftedCompare = defaultCompare - -let ~{ocaml} byte_liftedLess b1 b2 = byte_liftedCompare b1 b2 = LT -let ~{ocaml} byte_liftedLessEq b1 b2 = byte_liftedCompare b1 b2 <> GT -let ~{ocaml} byte_liftedGreater b1 b2 = byte_liftedCompare b1 b2 = GT -let ~{ocaml} byte_liftedGreaterEq b1 b2 = byte_liftedCompare b1 b2 <> LT - -let inline {ocaml} byte_liftedLess = defaultLess -let inline {ocaml} byte_liftedLessEq = defaultLessEq -let inline {ocaml} byte_liftedGreater = defaultGreater -let inline {ocaml} byte_liftedGreaterEq = defaultGreaterEq - -instance (Ord byte_lifted) - let compare = byte_liftedCompare - let (<) = byte_liftedLess - let (<=) = byte_liftedLessEq - let (>) = byte_liftedGreater - let (>=) = byte_liftedGreaterEq -end - -let ~{ocaml} byteCompare (Byte b1) (Byte b2) = compare b1 b2 -let inline {ocaml} byteCompare = defaultCompare - -let ~{ocaml} byteLess b1 b2 = byteCompare b1 b2 = LT -let ~{ocaml} byteLessEq b1 b2 = byteCompare b1 b2 <> GT -let ~{ocaml} byteGreater b1 b2 = byteCompare b1 b2 = GT -let ~{ocaml} byteGreaterEq b1 b2 = byteCompare b1 b2 <> LT - -let inline {ocaml} byteLess = defaultLess -let inline {ocaml} byteLessEq = defaultLessEq -let inline {ocaml} byteGreater = defaultGreater -let inline {ocaml} byteGreaterEq = defaultGreaterEq - -instance (Ord byte) - let compare = byteCompare - let (<) = byteLess - let (<=) = byteLessEq - let (>) = byteGreater - let (>=) = byteGreaterEq -end - - - - - -let ~{ocaml} opcodeCompare (Opcode o1) (Opcode o2) = - compare o1 o2 -let {ocaml} opcodeCompare = defaultCompare - -let ~{ocaml} opcodeLess b1 b2 = opcodeCompare b1 b2 = LT -let ~{ocaml} opcodeLessEq b1 b2 = opcodeCompare b1 b2 <> GT -let ~{ocaml} opcodeGreater b1 b2 = opcodeCompare b1 b2 = GT -let ~{ocaml} opcodeGreaterEq b1 b2 = opcodeCompare b1 b2 <> LT - -let inline {ocaml} opcodeLess = defaultLess -let inline {ocaml} opcodeLessEq = defaultLessEq -let inline {ocaml} opcodeGreater = defaultGreater -let inline {ocaml} opcodeGreaterEq = defaultGreaterEq - -instance (Ord opcode) - let compare = opcodeCompare - let (<) = opcodeLess - let (<=) = opcodeLessEq - let (>) = opcodeGreater - let (>=) = opcodeGreaterEq -end - -let addressCompare (Address b1 i1) (Address b2 i2) = compare i1 i2 -(* this cannot be defaultCompare for OCaml because addresses contain big ints *) - -let addressLess b1 b2 = addressCompare b1 b2 = LT -let addressLessEq b1 b2 = addressCompare b1 b2 <> GT -let addressGreater b1 b2 = addressCompare b1 b2 = GT -let addressGreaterEq b1 b2 = addressCompare b1 b2 <> LT - -instance (SetType address) - let setElemCompare = addressCompare -end - -instance (Ord address) - let compare = addressCompare - let (<) = addressLess - let (<=) = addressLessEq - let (>) = addressGreater - let (>=) = addressGreaterEq -end - -let {coq; ocaml} addressEqual a1 a2 = (addressCompare a1 a2) = EQ -let inline {hol; isabelle} addressEqual = unsafe_structural_equality - -let {coq; ocaml} addressInequal a1 a2 = not (addressEqual a1 a2) -let inline {hol; isabelle} addressInequal = unsafe_structural_inequality - -instance (Eq address) - let (=) = addressEqual - let (<>) = addressInequal -end - -let ~{ocaml} directionCompare d1 d2 = - match (d1, d2) with - | (D_decreasing, D_increasing) -> GT - | (D_increasing, D_decreasing) -> LT - | _ -> EQ - end -let inline {ocaml} directionCompare = defaultCompare - -let ~{ocaml} directionLess b1 b2 = directionCompare b1 b2 = LT -let ~{ocaml} directionLessEq b1 b2 = directionCompare b1 b2 <> GT -let ~{ocaml} directionGreater b1 b2 = directionCompare b1 b2 = GT -let ~{ocaml} directionGreaterEq b1 b2 = directionCompare b1 b2 <> LT - -let inline {ocaml} directionLess = defaultLess -let inline {ocaml} directionLessEq = defaultLessEq -let inline {ocaml} directionGreater = defaultGreater -let inline {ocaml} directionGreaterEq = defaultGreaterEq - -instance (Ord direction) - let compare = directionCompare - let (<) = directionLess - let (<=) = directionLessEq - let (>) = directionGreater - let (>=) = directionGreaterEq -end - -instance (Show direction) - let show = function D_increasing -> "D_increasing" | D_decreasing -> "D_decreasing" end -end - -let ~{ocaml} register_valueCompare rv1 rv2 = - compare (rv1.rv_bits, rv1.rv_dir, rv1.rv_start, rv1.rv_start_internal) - (rv2.rv_bits, rv2.rv_dir, rv2.rv_start, rv2.rv_start_internal) -let inline {ocaml} register_valueCompare = defaultCompare - -let ~{ocaml} register_valueLess b1 b2 = register_valueCompare b1 b2 = LT -let ~{ocaml} register_valueLessEq b1 b2 = register_valueCompare b1 b2 <> GT -let ~{ocaml} register_valueGreater b1 b2 = register_valueCompare b1 b2 = GT -let ~{ocaml} register_valueGreaterEq b1 b2 = register_valueCompare b1 b2 <> LT - -let inline {ocaml} register_valueLess = defaultLess -let inline {ocaml} register_valueLessEq = defaultLessEq -let inline {ocaml} register_valueGreater = defaultGreater -let inline {ocaml} register_valueGreaterEq = defaultGreaterEq - -instance (Ord register_value) - let compare = register_valueCompare - let (<) = register_valueLess - let (<=) = register_valueLessEq - let (>) = register_valueGreater - let (>=) = register_valueGreaterEq -end - -let address_liftedCompare (Address_lifted b1 i1) (Address_lifted b2 i2) = - compare (i1,b1) (i2,b2) -(* this cannot be defaultCompare for OCaml because address_lifteds contain big - ints *) - -let address_liftedLess b1 b2 = address_liftedCompare b1 b2 = LT -let address_liftedLessEq b1 b2 = address_liftedCompare b1 b2 <> GT -let address_liftedGreater b1 b2 = address_liftedCompare b1 b2 = GT -let address_liftedGreaterEq b1 b2 = address_liftedCompare b1 b2 <> LT - -instance (Ord address_lifted) - let compare = address_liftedCompare - let (<) = address_liftedLess - let (<=) = address_liftedLessEq - let (>) = address_liftedGreater - let (>=) = address_liftedGreaterEq -end - -(* Registers *) -type slice = (nat * nat) - -type reg_name = - (* do we really need this here if ppcmem already has this information by itself? *) -| Reg of string * nat * nat * direction -(*Name of the register, accessing the entire register, the start and size of this register, and its direction *) - -| Reg_slice of string * nat * direction * slice -(* Name of the register, accessing from the bit indexed by the first -to the bit indexed by the second integer of the slice, inclusive. For -machineDef* the first is a smaller number or equal to the second, adjusted -to reflect the correct span direction in the interpreter side. *) - -| Reg_field of string * nat * direction * string * slice -(*Name of the register, start and direction, and name of the field of the register -accessed. The slice specifies where this field is in the register*) - -| Reg_f_slice of string * nat * direction * string * slice * slice -(* The first four components are as in Reg_field; the final slice -specifies a part of the field, indexed w.r.t. the register as a whole *) - -let register_base_name : reg_name -> string = function - | Reg s _ _ _ -> s - | Reg_slice s _ _ _ -> s - | Reg_field s _ _ _ _ -> s - | Reg_f_slice s _ _ _ _ _ -> s - end - -let slice_of_reg_name : reg_name -> slice = function - | Reg _ start width D_increasing -> (start, start + width -1) - | Reg _ start width D_decreasing -> (start - width - 1, start) - | Reg_slice _ _ _ sl -> sl - | Reg_field _ _ _ _ sl -> sl - | Reg_f_slice _ _ _ _ _ sl -> sl - end - -let width_of_reg_name (r: reg_name) : nat = - let width_of_slice (i, j) = (* j - i + 1 in *) - - (integerFromNat j) - (integerFromNat i) + 1 - $> abs $> natFromInteger - in - match r with - | Reg _ _ width _ -> width - | Reg_slice _ _ _ sl -> width_of_slice sl - | Reg_field _ _ _ _ sl -> width_of_slice sl - | Reg_f_slice _ _ _ _ _ sl -> width_of_slice sl - end - -let reg_name_non_empty_intersection (r: reg_name) (r': reg_name) : bool = - register_base_name r = register_base_name r' && - let (i1, i2) = slice_of_reg_name r in - let (i1', i2') = slice_of_reg_name r' in - i1' <= i2 && i2' >= i1 - -let reg_nameCompare r1 r2 = - compare (register_base_name r1,slice_of_reg_name r1) - (register_base_name r2,slice_of_reg_name r2) - -let reg_nameLess b1 b2 = reg_nameCompare b1 b2 = LT -let reg_nameLessEq b1 b2 = reg_nameCompare b1 b2 <> GT -let reg_nameGreater b1 b2 = reg_nameCompare b1 b2 = GT -let reg_nameGreaterEq b1 b2 = reg_nameCompare b1 b2 <> LT - -instance (Ord reg_name) - let compare = reg_nameCompare - let (<) = reg_nameLess - let (<=) = reg_nameLessEq - let (>) = reg_nameGreater - let (>=) = reg_nameGreaterEq -end - -let {coq;ocaml} reg_nameEqual a1 a2 = (reg_nameCompare a1 a2) = EQ -let {hol;isabelle} reg_nameEqual = unsafe_structural_equality -let {coq;ocaml} reg_nameInequal a1 a2 = not (reg_nameEqual a1 a2) -let {hol;isabelle} reg_nameInequal = unsafe_structural_inequality - -instance (Eq reg_name) - let (=) = reg_nameEqual - let (<>) = reg_nameInequal -end - -instance (SetType reg_name) - let setElemCompare = reg_nameCompare -end - -let direction_of_reg_name r = match r with - | Reg _ _ _ d -> d - | Reg_slice _ _ d _ -> d - | Reg_field _ _ d _ _ -> d - | Reg_f_slice _ _ d _ _ _ -> d - end - -let start_of_reg_name r = match r with - | Reg _ start _ _ -> start - | Reg_slice _ start _ _ -> start - | Reg_field _ start _ _ _ -> start - | Reg_f_slice _ start _ _ _ _ -> start -end - -(* Data structures for building up instructions *) - -(* read_kind, write_kind, barrier_kind, trans_kind and instruction_kind have - been moved to sail_instr_kinds.lem. This removes the dependency of the - shallow embedding on the rest of sail_impl_base.lem, and helps avoid name - clashes between the different monad types. *) - -type event = - | E_read_mem of read_kind * address_lifted * nat * maybe (list reg_name) - | E_read_memt of read_kind * address_lifted * nat * maybe (list reg_name) - | E_write_mem of write_kind * address_lifted * nat * maybe (list reg_name) * memory_value * maybe (list reg_name) - | E_write_ea of write_kind * address_lifted * nat * maybe (list reg_name) - | E_excl_res - | E_write_memv of maybe address_lifted * memory_value * maybe (list reg_name) - | E_write_memvt of maybe address_lifted * (bit_lifted * memory_value) * maybe (list reg_name) - | E_barrier of barrier_kind - | E_footprint - | E_read_reg of reg_name - | E_write_reg of reg_name * register_value - | E_escape - | E_error of string - - -let eventCompare e1 e2 = - match (e1,e2) with - | (E_read_mem rk1 v1 i1 tr1, E_read_mem rk2 v2 i2 tr2) -> - compare (rk1, (v1,i1,tr1)) (rk2,(v2, i2, tr2)) - | (E_read_memt rk1 v1 i1 tr1, E_read_memt rk2 v2 i2 tr2) -> - compare (rk1, (v1,i1,tr1)) (rk2,(v2, i2, tr2)) - | (E_write_mem wk1 v1 i1 tr1 v1' tr1', E_write_mem wk2 v2 i2 tr2 v2' tr2') -> - compare ((wk1,v1,i1),(tr1,v1',tr1')) ((wk2,v2,i2),(tr2,v2',tr2')) - | (E_write_ea wk1 a1 i1 tr1, E_write_ea wk2 a2 i2 tr2) -> - compare (wk1, (a1, i1, tr1)) (wk2, (a2, i2, tr2)) - | (E_excl_res, E_excl_res) -> EQ - | (E_write_memv _ mv1 tr1, E_write_memv _ mv2 tr2) -> compare (mv1,tr1) (mv2,tr2) - | (E_write_memvt _ mv1 tr1, E_write_memvt _ mv2 tr2) -> compare (mv1,tr1) (mv2,tr2) - | (E_barrier bk1, E_barrier bk2) -> compare bk1 bk2 - | (E_read_reg r1, E_read_reg r2) -> compare r1 r2 - | (E_write_reg r1 v1, E_write_reg r2 v2) -> compare (r1,v1) (r2,v2) - | (E_error s1, E_error s2) -> compare s1 s2 - | (E_escape,E_escape) -> EQ - | (E_read_mem _ _ _ _, _) -> LT - | (E_write_mem _ _ _ _ _ _, _) -> LT - | (E_write_ea _ _ _ _, _) -> LT - | (E_excl_res, _) -> LT - | (E_write_memv _ _ _, _) -> LT - | (E_barrier _, _) -> LT - | (E_read_reg _, _) -> LT - | (E_write_reg _ _, _) -> LT - | _ -> GT - end - -let eventLess b1 b2 = eventCompare b1 b2 = LT -let eventLessEq b1 b2 = eventCompare b1 b2 <> GT -let eventGreater b1 b2 = eventCompare b1 b2 = GT -let eventGreaterEq b1 b2 = eventCompare b1 b2 <> LT - -instance (Ord event) - let compare = eventCompare - let (<) = eventLess - let (<=) = eventLessEq - let (>) = eventGreater - let (>=) = eventGreaterEq -end - -instance (SetType event) - let setElemCompare = compare -end - - -(* the address_lifted types should go away here and be replaced by address *) -type with_aux 'o = 'o * maybe ((unit -> (string * string)) * ((list (reg_name * register_value)) -> list event)) -type outcome 'a 'e = - (* Request to read memory, value is location to read, integer is size to read, - followed by registers that were used in computing that size *) - | Read_mem of (read_kind * address_lifted * nat) * (memory_value -> with_aux (outcome 'a 'e)) - (* Tell the system a write is imminent, at address lifted, of size nat *) - | Write_ea of (write_kind * address_lifted * nat) * (with_aux (outcome 'a 'e)) - (* Request the result of store-exclusive *) - | Excl_res of (bool -> with_aux (outcome 'a 'e)) - (* Request to write memory at last signalled address. Memory value should be 8 - times the size given in ea signal *) - | Write_memv of memory_value * (bool -> with_aux (outcome 'a 'e)) - (* Request a memory barrier *) - | Barrier of barrier_kind * with_aux (outcome 'a 'e) - (* Tell the system to dynamically recalculate dependency footprint *) - | Footprint of with_aux (outcome 'a 'e) - (* Request to read register, will track dependency when mode.track_values *) - | Read_reg of reg_name * (register_value -> with_aux (outcome 'a 'e)) - (* Request to write register *) - | Write_reg of (reg_name * register_value) * with_aux (outcome 'a 'e) - | Escape of maybe string - (*Result of a failed assert with possible error message to report*) - | Fail of maybe string - (* Exception of type 'e *) - | Exception of 'e - | Internal of (maybe string * maybe (unit -> string)) * with_aux (outcome 'a 'e) - | Done of 'a - | Error of string - -type outcome_s 'a 'e = with_aux (outcome 'a 'e) -(* first string : output of instruction_stack_to_string - second string: output of local_variables_to_string *) - -(** operations and coercions on basic values *) - -val word8_to_bitls : word8 -> list bit_lifted -val bitls_to_word8 : list bit_lifted -> word8 - -val integer_of_word8_list : list word8 -> integer -val word8_list_of_integer : integer -> integer -> list word8 - -val concretizable_bitl : bit_lifted -> bool -val concretizable_bytl : byte_lifted -> bool -val concretizable_bytls : list byte_lifted -> bool - -let concretizable_bitl = function - | Bitl_zero -> true - | Bitl_one -> true - | Bitl_undef -> false - | Bitl_unknown -> false -end - -let concretizable_bytl (Byte_lifted bs) = List.all concretizable_bitl bs -let concretizable_bytls = List.all concretizable_bytl - -(* constructing values *) - -val build_register_value : list bit_lifted -> direction -> nat -> nat -> register_value -let build_register_value bs dir width start_index = - <| rv_bits = bs; - rv_dir = dir; (* D_increasing for Power, D_decreasing for ARM *) - rv_start_internal = start_index; - rv_start = if dir = D_increasing - then start_index - else (start_index+1) - width; (* Smaller index, as in Power, for external interaction *) - |> - -val register_value : bit_lifted -> direction -> nat -> nat -> register_value -let register_value b dir width start_index = - build_register_value (List.replicate width b) dir width start_index - -val register_value_zeros : direction -> nat -> nat -> register_value -let register_value_zeros dir width start_index = - register_value Bitl_zero dir width start_index - -val register_value_ones : direction -> nat -> nat -> register_value -let register_value_ones dir width start_index = - register_value Bitl_one dir width start_index - -val register_value_for_reg : reg_name -> list bit_lifted -> register_value -let register_value_for_reg r bs : register_value = - let () = ensure (width_of_reg_name r = List.length bs) - ("register_value_for_reg (\"" ^ show (register_base_name r) ^ "\") length mismatch: " - ^ show (width_of_reg_name r) ^ " vs " ^ show (List.length bs)) - in - let (j1, j2) = slice_of_reg_name r in - let d = direction_of_reg_name r in - <| rv_bits = bs; - rv_dir = d; - rv_start_internal = if d = D_increasing then j1 else (start_of_reg_name r) - j1; - rv_start = j1; - |> - -val byte_lifted_undef : byte_lifted -let byte_lifted_undef = Byte_lifted (List.replicate 8 Bitl_undef) - -val byte_lifted_unknown : byte_lifted -let byte_lifted_unknown = Byte_lifted (List.replicate 8 Bitl_unknown) - -val memory_value_unknown : nat (*the number of bytes*) -> memory_value -let memory_value_unknown (width:nat) : memory_value = - List.replicate width byte_lifted_unknown - -val memory_value_undef : nat (*the number of bytes*) -> memory_value -let memory_value_undef (width:nat) : memory_value = - List.replicate width byte_lifted_undef - -val match_endianness : forall 'a. end_flag -> list 'a -> list 'a -let match_endianness endian l = - match endian with - | E_little_endian -> List.reverse l - | E_big_endian -> l - end - -(* lengths *) - -val memory_value_length : memory_value -> nat -let memory_value_length (mv:memory_value) = List.length mv - - -(* aux fns *) - -val maybe_all : forall 'a. list (maybe 'a) -> maybe (list 'a) -let rec maybe_all' xs acc = - match xs with - | [] -> Just (List.reverse acc) - | Nothing :: _ -> Nothing - | (Just y)::xs' -> maybe_all' xs' (y::acc) - end -let maybe_all xs = maybe_all' xs [] - -(** coercions *) - -(* bits and bytes *) - -let bit_to_bool = function (* TODO: rename bool_of_bit *) - | Bitc_zero -> false - | Bitc_one -> true -end - - -val bit_lifted_of_bit : bit -> bit_lifted -let bit_lifted_of_bit b = - match b with - | Bitc_zero -> Bitl_zero - | Bitc_one -> Bitl_one - end - -val bit_of_bit_lifted : bit_lifted -> maybe bit -let bit_of_bit_lifted bl = - match bl with - | Bitl_zero -> Just Bitc_zero - | Bitl_one -> Just Bitc_one - | Bitl_undef -> Nothing - | Bitl_unknown -> Nothing - end - - -val byte_lifted_of_byte : byte -> byte_lifted -let byte_lifted_of_byte (Byte bs) : byte_lifted = Byte_lifted (List.map bit_lifted_of_bit bs) - -val byte_of_byte_lifted : byte_lifted -> maybe byte -let byte_of_byte_lifted bl = - match bl with - | Byte_lifted bls -> - match maybe_all (List.map bit_of_bit_lifted bls) with - | Nothing -> Nothing - | Just bs -> Just (Byte bs) - end - end - - -val bytes_of_bits : list bit -> list byte (*assumes (length bits) mod 8 = 0*) -let rec bytes_of_bits bits = match bits with - | [] -> [] - | b0::b1::b2::b3::b4::b5::b6::b7::bits -> - (Byte [b0;b1;b2;b3;b4;b5;b6;b7])::(bytes_of_bits bits) - | _ -> failwith "bytes_of_bits not given bits divisible by 8" -end - -val byte_lifteds_of_bit_lifteds : list bit_lifted -> list byte_lifted (*assumes (length bits) mod 8 = 0*) -let rec byte_lifteds_of_bit_lifteds bits = match bits with - | [] -> [] - | b0::b1::b2::b3::b4::b5::b6::b7::bits -> - (Byte_lifted [b0;b1;b2;b3;b4;b5;b6;b7])::(byte_lifteds_of_bit_lifteds bits) - | _ -> failwith "byte_lifteds of bit_lifteds not given bits divisible by 8" -end - - -val byte_of_memory_byte : memory_byte -> maybe byte -let byte_of_memory_byte = byte_of_byte_lifted - -val memory_byte_of_byte : byte -> memory_byte -let memory_byte_of_byte = byte_lifted_of_byte - - -(* to and from nat *) - -(* this natFromBoolList could move to the Lem word.lem library *) -val natFromBoolList : list bool -> nat -let rec natFromBoolListAux (acc : nat) (bl : list bool) = - match bl with - | [] -> acc - | (true :: bl') -> natFromBoolListAux ((acc * 2) + 1) bl' - | (false :: bl') -> natFromBoolListAux (acc * 2) bl' - end -let natFromBoolList bl = - natFromBoolListAux 0 (List.reverse bl) - - -val nat_of_bit_list : list bit -> nat -let nat_of_bit_list b = - natFromBoolList (List.reverse (List.map bit_to_bool b)) - (* natFromBoolList takes a list with LSB first, for consistency with rest of Lem word library, so we reverse it. twice. *) - - -(* to and from integer *) - -val integer_of_bit_list : list bit -> integer -let integer_of_bit_list b = - integerFromBoolList (false,(List.reverse (List.map bit_to_bool b))) - (* integerFromBoolList takes a list with LSB first, so we reverse it *) - -val bit_list_of_integer : nat -> integer -> list bit -let bit_list_of_integer len b = - List.map (fun b -> if b then Bitc_one else Bitc_zero) - (reverse (boolListFrombitSeq len (bitSeqFromInteger Nothing b))) - -val integer_of_byte_list : list byte -> integer -let integer_of_byte_list bytes = integer_of_bit_list (List.concatMap (fun (Byte bs) -> bs) bytes) - -val byte_list_of_integer : nat -> integer -> list byte -let byte_list_of_integer (len:nat) (a:integer):list byte = - let bits = bit_list_of_integer (len * 8) a in bytes_of_bits bits - - -val integer_of_address : address -> integer -let integer_of_address (a:address):integer = - match a with - | Address bs i -> i - end - -val address_of_integer : integer -> address -let address_of_integer (i:integer):address = - Address (byte_list_of_integer 8 i) i - -(* to and from signed-integer *) - -val signed_integer_of_bit_list : list bit -> integer -let signed_integer_of_bit_list b = - match b with - | [] -> failwith "empty bit list" - | Bitc_zero :: b' -> - integerFromBoolList (false,(List.reverse (List.map bit_to_bool b))) - | Bitc_one :: b' -> - let b'_val = integerFromBoolList (false,(List.reverse (List.map bit_to_bool b'))) in - (* integerFromBoolList takes a list with LSB first, so we reverse it *) - let msb_val = integerPow 2 ((List.length b) - 1) in - b'_val - msb_val - end - - -(* regarding a list of int as a list of bytes in memory, MSB lowest-address first, convert to an integer *) -val integer_address_of_int_list : list int -> integer -let rec integerFromIntListAux (acc: integer) (is: list int) = - match is with - | [] -> acc - | (i :: is') -> integerFromIntListAux ((acc * 256) + integerFromInt i) is' - end -let integer_address_of_int_list (is: list int) = - integerFromIntListAux 0 is - -val address_of_byte_list : list byte -> address -let address_of_byte_list bs = - if List.length bs <> 8 then failwith "address_of_byte_list given list not of length 8" else - Address bs (integer_of_byte_list bs) - -let address_of_byte_lifted_list bls = - match maybe_all (List.map byte_of_byte_lifted bls) with - | Nothing -> Nothing - | Just bs -> Just (address_of_byte_list bs) - end - -(* operations on addresses *) - -val add_address_nat : address -> nat -> address -let add_address_nat (a:address) (i:nat) : address = - address_of_integer ((integer_of_address a) + (integerFromNat i)) - -val clear_low_order_bits_of_address : address -> address -let clear_low_order_bits_of_address a = - match a with - | Address [b0;b1;b2;b3;b4;b5;b6;b7] i -> - match b7 with - | Byte [bt0;bt1;bt2;bt3;bt4;bt5;bt6;bt7] -> - let b7' = Byte [bt0;bt1;bt2;bt3;bt4;bt5;Bitc_zero;Bitc_zero] in - let bytes = [b0;b1;b2;b3;b4;b5;b6;b7'] in - Address bytes (integer_of_byte_list bytes) - | _ -> failwith "Byte does not contain 8 bits" - end - | _ -> failwith "Address does not contain 8 bytes" - end - - - -val byte_list_of_memory_value : end_flag -> memory_value -> maybe (list byte) -let byte_list_of_memory_value endian mv = - match_endianness endian mv - $> List.map byte_of_memory_byte - $> maybe_all - - -val integer_of_memory_value : end_flag -> memory_value -> maybe integer -let integer_of_memory_value endian (mv:memory_value):maybe integer = - match byte_list_of_memory_value endian mv with - | Just bs -> Just (integer_of_byte_list bs) - | Nothing -> Nothing - end - -val memory_value_of_integer : end_flag -> nat -> integer -> memory_value -let memory_value_of_integer endian (len:nat) (i:integer):memory_value = - List.map byte_lifted_of_byte (byte_list_of_integer len i) - $> match_endianness endian - - -val integer_of_register_value : register_value -> maybe integer -let integer_of_register_value (rv:register_value):maybe integer = - match maybe_all (List.map bit_of_bit_lifted rv.rv_bits) with - | Nothing -> Nothing - | Just bs -> Just (integer_of_bit_list bs) - end - -(* NOTE: register_value_for_reg_of_integer might be easier to use *) -val register_value_of_integer : nat -> nat -> direction -> integer -> register_value -let register_value_of_integer (len:nat) (start:nat) (dir:direction) (i:integer):register_value = - let bs = bit_list_of_integer len i in - build_register_value (List.map bit_lifted_of_bit bs) dir len start - -val register_value_for_reg_of_integer : reg_name -> integer -> register_value -let register_value_for_reg_of_integer (r: reg_name) (i:integer) : register_value = - register_value_of_integer (width_of_reg_name r) (start_of_reg_name r) (direction_of_reg_name r) i - -(* *) - -val opcode_of_bytes : byte -> byte -> byte -> byte -> opcode -let opcode_of_bytes b0 b1 b2 b3 : opcode = Opcode [b0;b1;b2;b3] - -val register_value_of_address : address -> direction -> register_value -let register_value_of_address (Address bytes _) dir : register_value = - let bits = List.concatMap (fun (Byte bs) -> List.map bit_lifted_of_bit bs) bytes in - <| rv_bits = bits; - rv_dir = dir; - rv_start = 0; - rv_start_internal = if dir = D_increasing then 0 else (List.length bits) - 1 - |> - -val register_value_of_memory_value : memory_value -> direction -> register_value -let register_value_of_memory_value bytes dir : register_value = - let bitls = List.concatMap (fun (Byte_lifted bs) -> bs) bytes in - <| rv_bits = bitls; - rv_dir = dir; - rv_start = 0; - rv_start_internal = if dir = D_increasing then 0 else (List.length bitls) - 1 - |> - -val memory_value_of_register_value: register_value -> memory_value -let memory_value_of_register_value r = - (byte_lifteds_of_bit_lifteds r.rv_bits) - -val address_lifted_of_register_value : register_value -> maybe address_lifted -(* returning Nothing iff the register value is not 64 bits wide, but -allowing Bitl_undef and Bitl_unknown *) -let address_lifted_of_register_value (rv:register_value) : maybe address_lifted = - if List.length rv.rv_bits <> 64 then Nothing - else - Just (Address_lifted (byte_lifteds_of_bit_lifteds rv.rv_bits) - (if List.all concretizable_bitl rv.rv_bits - then match (maybe_all (List.map bit_of_bit_lifted rv.rv_bits)) with - | (Just(bits)) -> Just (integer_of_bit_list bits) - | Nothing -> Nothing end - else Nothing)) - -val address_of_address_lifted : address_lifted -> maybe address -(* returning Nothing iff the address contains any Bitl_undef or Bitl_unknown *) -let address_of_address_lifted (al:address_lifted): maybe address = - match al with - | Address_lifted bls (Just i)-> - match maybe_all ((List.map byte_of_byte_lifted) bls) with - | Nothing -> Nothing - | Just bs -> Just (Address bs i) - end - | _ -> Nothing -end - -val address_of_register_value : register_value -> maybe address -(* returning Nothing iff the register value is not 64 bits wide, or contains Bitl_undef or Bitl_unknown *) -let address_of_register_value (rv:register_value) : maybe address = - match address_lifted_of_register_value rv with - | Nothing -> Nothing - | Just al -> - match address_of_address_lifted al with - | Nothing -> Nothing - | Just a -> Just a - end - end - -let address_of_memory_value (endian: end_flag) (mv:memory_value) : maybe address = - match byte_list_of_memory_value endian mv with - | Nothing -> Nothing - | Just bs -> - if List.length bs <> 8 then Nothing else - Just (address_of_byte_list bs) - end - -val byte_of_int : int -> byte -let byte_of_int (i:int) : byte = - Byte (bit_list_of_integer 8 (integerFromInt i)) - -val memory_byte_of_int : int -> memory_byte -let memory_byte_of_int (i:int) : memory_byte = - memory_byte_of_byte (byte_of_int i) - -(* -val int_of_memory_byte : int -> maybe memory_byte -let int_of_memory_byte (mb:memory_byte) : int = - failwith "TODO" -*) - - - -val memory_value_of_address_lifted : end_flag -> address_lifted -> memory_value -let memory_value_of_address_lifted endian (Address_lifted bs _ :address_lifted) = - match_endianness endian bs - -val byte_list_of_address : address -> list byte -let byte_list_of_address (Address bs _) : list byte = bs - -val memory_value_of_address : end_flag -> address -> memory_value -let memory_value_of_address endian (Address bs _) = - match_endianness endian bs - $> List.map byte_lifted_of_byte - -val byte_list_of_opcode : opcode -> list byte -let byte_list_of_opcode (Opcode bs) : list byte = bs - -(** ****************************************** *) -(** show type class instantiations *) -(** ****************************************** *) - -(* matching printing_functions.ml *) -val stringFromReg_name : reg_name -> string -let stringFromReg_name r = - let norm_sl start dir (first,second) = (first,second) - (* match dir with - | D_increasing -> (first,second) - | D_decreasing -> (start - first, start - second) - end *) - in - match r with - | Reg s start size dir -> s - | Reg_slice s start dir sl -> - let (first,second) = norm_sl start dir sl in - s ^ "[" ^ show first ^ (if (first = second) then "" else ".." ^ (show second)) ^ "]" - | Reg_field s start dir f sl -> - let (first,second) = norm_sl start dir sl in - s ^ "." ^ f ^ " (" ^ (show start) ^ ", " ^ (show dir) ^ ", " ^ (show first) ^ ", " ^ (show second) ^ ")" - | Reg_f_slice s start dir f (first1,second1) (first,second) -> - let (first,second) = - match dir with - | D_increasing -> (first,second) - | D_decreasing -> (start - first, start - second) - end in - s ^ "." ^ f ^ "]" ^ show first ^ (if (first = second) then "" else ".." ^ (show second)) ^ "]" - end - -instance (Show reg_name) - let show = stringFromReg_name -end - - -(* hex pp of integers, adapting the Lem string_extra.lem code *) -val stringFromNaturalHexHelper : natural -> list char -> list char -let rec stringFromNaturalHexHelper n acc = - if n = 0 then - acc - else - stringFromNaturalHexHelper (n / 16) (String_extra.chr (natFromNatural (let nd = n mod 16 in if nd <=9 then nd + 48 else nd - 10 + 97)) :: acc) - -val stringFromNaturalHex : natural -> string -let (*~{ocaml;hol}*) stringFromNaturalHex n = - if n = 0 then "0" else toString (stringFromNaturalHexHelper n []) - -val stringFromIntegerHex : integer -> string -let (*~{ocaml}*) stringFromIntegerHex i = - if i < 0 then - "-" ^ stringFromNaturalHex (naturalFromInteger i) - else - stringFromNaturalHex (naturalFromInteger i) - - -let stringFromAddress (Address bs i) = - let i' = integer_of_byte_list bs in - if i=i' then -(*TODO: ideally this should be made to match the src/pp.ml pp_address; the following very roughly matches what's used in the ppcmem UI, enough to make exceptions readable *) - if i < 65535 then - show i - else - stringFromIntegerHex i - else - "stringFromAddress bytes and integer mismatch" - -instance (Show address) - let show = stringFromAddress -end - -let stringFromByte_lifted bl = - match byte_of_byte_lifted bl with - | Nothing -> "u?" - | Just (Byte bits) -> - let i = integer_of_bit_list bits in - show i - end - -instance (Show byte_lifted) - let show = stringFromByte_lifted -end - -(* possible next instruction address options *) -type nia = - | NIA_successor - | NIA_concrete_address of address - | NIA_indirect_address - -let niaCompare n1 n2 = match (n1,n2) with - | (NIA_successor, NIA_successor) -> EQ - | (NIA_successor, _) -> LT - | (_, NIA_successor) -> GT - | (NIA_concrete_address a1, NIA_concrete_address a2) -> compare a1 a2 - | (NIA_concrete_address _, _) -> LT - | (_, NIA_concrete_address _) -> GT - | (NIA_indirect_address, NIA_indirect_address) -> EQ - (* | (NIA_indirect_address, _) -> LT - | (_, NIA_indirect_address) -> GT *) - end - -instance (Ord nia) - let compare = niaCompare - let (<) n1 n2 = (niaCompare n1 n2) = LT - let (<=) n1 n2 = (niaCompare n1 n2) <> GT - let (>) n1 n2 = (niaCompare n1 n2) = GT - let (>=) n1 n2 = (niaCompare n1 n2) <> LT -end - -let stringFromNia = function - | NIA_successor -> "NIA_successor" - | NIA_concrete_address a -> "NIA_concrete_address " ^ show a - | NIA_indirect_address -> "NIA_indirect_address" -end - -instance (Show nia) - let show = stringFromNia -end - -type dia = - | DIA_none - | DIA_concrete_address of address - | DIA_register of reg_name - -let diaCompare d1 d2 = match (d1, d2) with - | (DIA_none, DIA_none) -> EQ - | (DIA_none, _) -> LT - | (DIA_concrete_address a1, DIA_none) -> GT - | (DIA_concrete_address a1, DIA_concrete_address a2) -> compare a1 a2 - | (DIA_concrete_address a1, _) -> LT - | (DIA_register r1, DIA_register r2) -> compare r1 r2 - | (DIA_register _, _) -> GT -end - -instance (Ord dia) - let compare = diaCompare - let (<) n1 n2 = (diaCompare n1 n2) = LT - let (<=) n1 n2 = (diaCompare n1 n2) <> GT - let (>) n1 n2 = (diaCompare n1 n2) = GT - let (>=) n1 n2 = (diaCompare n1 n2) <> LT -end - -let stringFromDia = function - | DIA_none -> "DIA_none" - | DIA_concrete_address a -> "DIA_concrete_address " ^ show a - | DIA_register r -> "DIA_delayed_register " ^ show r -end - -instance (Show dia) - let show = stringFromDia -end diff --git a/src/lem_interp/0.11/sail2_instr_kinds.lem b/src/lem_interp/0.11/sail2_instr_kinds.lem deleted file mode 100644 index f3cdfbc9..00000000 --- a/src/lem_interp/0.11/sail2_instr_kinds.lem +++ /dev/null @@ -1,376 +0,0 @@ -(*========================================================================*) -(* Sail *) -(* *) -(* Copyright (c) 2013-2017 *) -(* Kathyrn Gray *) -(* Shaked Flur *) -(* Stephen Kell *) -(* Gabriel Kerneis *) -(* Robert Norton-Wright *) -(* Christopher Pulte *) -(* Peter Sewell *) -(* Alasdair Armstrong *) -(* Brian Campbell *) -(* Thomas Bauereiss *) -(* Anthony Fox *) -(* Jon French *) -(* Dominic Mulligan *) -(* Stephen Kell *) -(* Mark Wassell *) -(* *) -(* All rights reserved. *) -(* *) -(* This software was developed by the University of Cambridge Computer *) -(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) -(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) -(* *) -(* Redistribution and use in source and binary forms, with or without *) -(* modification, are permitted provided that the following conditions *) -(* are met: *) -(* 1. Redistributions of source code must retain the above copyright *) -(* notice, this list of conditions and the following disclaimer. *) -(* 2. Redistributions in binary form must reproduce the above copyright *) -(* notice, this list of conditions and the following disclaimer in *) -(* the documentation and/or other materials provided with the *) -(* distribution. *) -(* *) -(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) -(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) -(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) -(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) -(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) -(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) -(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) -(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) -(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) -(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) -(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) -(* SUCH DAMAGE. *) -(*========================================================================*) - -open import Pervasives_extra - - -class ( EnumerationType 'a ) - val toNat : 'a -> nat -end - - -val enumeration_typeCompare : forall 'a. EnumerationType 'a => 'a -> 'a -> ordering -let ~{ocaml} enumeration_typeCompare e1 e2 = - compare (toNat e1) (toNat e2) -let inline {ocaml} enumeration_typeCompare = defaultCompare - - -default_instance forall 'a. EnumerationType 'a => (Ord 'a) - let compare = enumeration_typeCompare - let (<) r1 r2 = (enumeration_typeCompare r1 r2) = LT - let (<=) r1 r2 = (enumeration_typeCompare r1 r2) <> GT - let (>) r1 r2 = (enumeration_typeCompare r1 r2) = GT - let (>=) r1 r2 = (enumeration_typeCompare r1 r2) <> LT -end - - -(* Data structures for building up instructions *) - -(* careful: changes in the read/write/barrier kinds have to be - reflected in deep_shallow_convert *) -type read_kind = - (* common reads *) - | Read_plain - (* Power reads *) - | Read_reserve - (* AArch64 reads *) - | Read_acquire | Read_exclusive | Read_exclusive_acquire | Read_stream - (* RISC-V reads *) - | Read_RISCV_acquire | Read_RISCV_strong_acquire - | Read_RISCV_reserved | Read_RISCV_reserved_acquire - | Read_RISCV_reserved_strong_acquire - (* x86 reads *) - | Read_X86_locked (* the read part of a lock'd instruction (rmw) *) - -instance (Show read_kind) - let show = function - | Read_plain -> "Read_plain" - | Read_reserve -> "Read_reserve" - | Read_acquire -> "Read_acquire" - | Read_exclusive -> "Read_exclusive" - | Read_exclusive_acquire -> "Read_exclusive_acquire" - | Read_stream -> "Read_stream" - | Read_RISCV_acquire -> "Read_RISCV_acquire" - | Read_RISCV_strong_acquire -> "Read_RISCV_strong_acquire" - | Read_RISCV_reserved -> "Read_RISCV_reserved" - | Read_RISCV_reserved_acquire -> "Read_RISCV_reserved_acquire" - | Read_RISCV_reserved_strong_acquire -> "Read_RISCV_reserved_strong_acquire" - | Read_X86_locked -> "Read_X86_locked" - end -end - -type write_kind = - (* common writes *) - | Write_plain - (* Power writes *) - | Write_conditional - (* AArch64 writes *) - | Write_release | Write_exclusive | Write_exclusive_release - (* RISC-V *) - | Write_RISCV_release | Write_RISCV_strong_release - | Write_RISCV_conditional | Write_RISCV_conditional_release - | Write_RISCV_conditional_strong_release - (* x86 writes *) - | Write_X86_locked (* the write part of a lock'd instruction (rmw) *) - -instance (Show write_kind) - let show = function - | Write_plain -> "Write_plain" - | Write_conditional -> "Write_conditional" - | Write_release -> "Write_release" - | Write_exclusive -> "Write_exclusive" - | Write_exclusive_release -> "Write_exclusive_release" - | Write_RISCV_release -> "Write_RISCV_release" - | Write_RISCV_strong_release -> "Write_RISCV_strong_release" - | Write_RISCV_conditional -> "Write_RISCV_conditional" - | Write_RISCV_conditional_release -> "Write_RISCV_conditional_release" - | Write_RISCV_conditional_strong_release -> "Write_RISCV_conditional_strong_release" - | Write_X86_locked -> "Write_X86_locked" - end -end - -type a64_barrier_domain = - A64_FullShare - | A64_InnerShare - | A64_OuterShare - | A64_NonShare - -type a64_barrier_type = - A64_barrier_all - | A64_barrier_LD - | A64_barrier_ST - -type barrier_kind = - (* Power barriers *) - Barrier_Sync of unit | Barrier_LwSync of unit | Barrier_Eieio of unit | Barrier_Isync of unit - (* AArch64 barriers *) - | Barrier_DMB of (a64_barrier_domain * a64_barrier_type) - | Barrier_DSB of (a64_barrier_domain * a64_barrier_type) - | Barrier_ISB of unit - | Barrier_TM_COMMIT of unit - (* MIPS barriers *) - | Barrier_MIPS_SYNC of unit - (* RISC-V barriers *) - | Barrier_RISCV_rw_rw of unit - | Barrier_RISCV_r_rw of unit - | Barrier_RISCV_r_r of unit - | Barrier_RISCV_rw_w of unit - | Barrier_RISCV_w_w of unit - | Barrier_RISCV_w_rw of unit - | Barrier_RISCV_rw_r of unit - | Barrier_RISCV_r_w of unit - | Barrier_RISCV_w_r of unit - | Barrier_RISCV_tso of unit - | Barrier_RISCV_i of unit - (* X86 *) - | Barrier_x86_MFENCE of unit - -let string_a64_barrier_domain = function - | A64_FullShare -> "A64_FullShare" - | A64_InnerShare -> "A64_InnerShare" - | A64_OuterShare -> "A64_OuterShare" - | A64_NonShare -> "A64_NonShare" -end - -instance (Show a64_barrier_domain) - let show = string_a64_barrier_domain -end - -let string_a64_barrier_type = function - | A64_barrier_all -> "A64_barrier_all" - | A64_barrier_LD -> "A64_barrier_LD" - | A64_barrier_ST -> "A64_barrier_ST" -end - -instance (Show a64_barrier_type) - let show = string_a64_barrier_type -end - -instance (Show barrier_kind) - let show = function - | Barrier_Sync () -> "Barrier_Sync" - | Barrier_LwSync () -> "Barrier_LwSync" - | Barrier_Eieio () -> "Barrier_Eieio" - | Barrier_Isync () -> "Barrier_Isync" - | Barrier_DMB (dom,typ) -> "Barrier_DMB (" ^ (show dom) ^ ", " ^ (show typ) ^ ")" - | Barrier_DSB (dom,typ) -> "Barrier_DSB (" ^ (show dom) ^ ", " ^ (show typ) ^ ")" - | Barrier_ISB () -> "Barrier_ISB" - | Barrier_TM_COMMIT () -> "Barrier_TM_COMMIT" - | Barrier_MIPS_SYNC () -> "Barrier_MIPS_SYNC" - | Barrier_RISCV_rw_rw () -> "Barrier_RISCV_rw_rw" - | Barrier_RISCV_r_rw () -> "Barrier_RISCV_r_rw" - | Barrier_RISCV_r_r () -> "Barrier_RISCV_r_r" - | Barrier_RISCV_rw_w () -> "Barrier_RISCV_rw_w" - | Barrier_RISCV_w_w () -> "Barrier_RISCV_w_w" - | Barrier_RISCV_w_rw () -> "Barrier_RISCV_w_rw" - | Barrier_RISCV_rw_r () -> "Barrier_RISCV_rw_r" - | Barrier_RISCV_r_w () -> "Barrier_RISCV_r_w" - | Barrier_RISCV_w_r () -> "Barrier_RISCV_w_r" - | Barrier_RISCV_tso () -> "Barrier_RISCV_tso" - | Barrier_RISCV_i () -> "Barrier_RISCV_i" - | Barrier_x86_MFENCE () -> "Barrier_x86_MFENCE" - end -end - -type trans_kind = - (* AArch64 *) - | Transaction_start | Transaction_commit | Transaction_abort - -instance (Show trans_kind) - let show = function - | Transaction_start -> "Transaction_start" - | Transaction_commit -> "Transaction_commit" - | Transaction_abort -> "Transaction_abort" - end -end - -(* cache maintenance instructions *) -type cache_op_kind = - (* AArch64 DC *) - | Cache_op_D_IVAC | Cache_op_D_ISW | Cache_op_D_CSW | Cache_op_D_CISW - | Cache_op_D_ZVA | Cache_op_D_CVAC | Cache_op_D_CVAU | Cache_op_D_CIVAC - (* AArch64 IC *) - | Cache_op_I_IALLUIS | Cache_op_I_IALLU | Cache_op_I_IVAU - -instance (Show cache_op_kind) - let show = function - | Cache_op_D_IVAC -> "Cache_op_D_IVAC" - | Cache_op_D_ISW -> "Cache_op_D_ISW" - | Cache_op_D_CSW -> "Cache_op_D_CSW" - | Cache_op_D_CISW -> "Cache_op_D_CISW" - | Cache_op_D_ZVA -> "Cache_op_D_ZVA" - | Cache_op_D_CVAC -> "Cache_op_D_CVAC" - | Cache_op_D_CVAU -> "Cache_op_D_CVAU" - | Cache_op_D_CIVAC -> "Cache_op_D_CIVAC" - | Cache_op_I_IALLUIS -> "Cache_op_I_IALLUIS" - | Cache_op_I_IALLU -> "Cache_op_I_IALLU" - | Cache_op_I_IVAU -> "Cache_op_I_IVAU" - end -end - -type instruction_kind = - | IK_barrier of barrier_kind - | IK_mem_read of read_kind - | IK_mem_write of write_kind - | IK_mem_rmw of (read_kind * write_kind) - | IK_branch of unit(* this includes conditional-branch (multiple nias, none of which is NIA_indirect_address), - indirect/computed-branch (single nia of kind NIA_indirect_address) - and branch/jump (single nia of kind NIA_concrete_address) *) - | IK_trans of trans_kind - | IK_simple of unit - | IK_cache_op of cache_op_kind - - -instance (Show instruction_kind) - let show = function - | IK_barrier barrier_kind -> "IK_barrier " ^ (show barrier_kind) - | IK_mem_read read_kind -> "IK_mem_read " ^ (show read_kind) - | IK_mem_write write_kind -> "IK_mem_write " ^ (show write_kind) - | IK_mem_rmw (r, w) -> "IK_mem_rmw " ^ (show r) ^ " " ^ (show w) - | IK_branch () -> "IK_branch" - | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) - | IK_simple () -> "IK_simple" - | IK_cache_op cache_kind -> "IK_cache_op " ^ (show cache_kind) - end -end - - -let read_is_exclusive = function - | Read_plain -> false - | Read_reserve -> true - | Read_acquire -> false - | Read_exclusive -> true - | Read_exclusive_acquire -> true - | Read_stream -> false - | Read_RISCV_acquire -> false - | Read_RISCV_strong_acquire -> false - | Read_RISCV_reserved -> true - | Read_RISCV_reserved_acquire -> true - | Read_RISCV_reserved_strong_acquire -> true - | Read_X86_locked -> true -end - - - -instance (EnumerationType read_kind) - let toNat = function - | Read_plain -> 0 - | Read_reserve -> 1 - | Read_acquire -> 2 - | Read_exclusive -> 3 - | Read_exclusive_acquire -> 4 - | Read_stream -> 5 - | Read_RISCV_acquire -> 6 - | Read_RISCV_strong_acquire -> 7 - | Read_RISCV_reserved -> 8 - | Read_RISCV_reserved_acquire -> 9 - | Read_RISCV_reserved_strong_acquire -> 10 - | Read_X86_locked -> 11 - end -end - -instance (EnumerationType write_kind) - let toNat = function - | Write_plain -> 0 - | Write_conditional -> 1 - | Write_release -> 2 - | Write_exclusive -> 3 - | Write_exclusive_release -> 4 - | Write_RISCV_release -> 5 - | Write_RISCV_strong_release -> 6 - | Write_RISCV_conditional -> 7 - | Write_RISCV_conditional_release -> 8 - | Write_RISCV_conditional_strong_release -> 9 - | Write_X86_locked -> 10 - end -end - -instance (EnumerationType a64_barrier_domain) - let toNat = function - | A64_FullShare -> 0 - | A64_InnerShare -> 1 - | A64_OuterShare -> 2 - | A64_NonShare -> 3 - end -end - -instance (EnumerationType a64_barrier_type) - let toNat = function - | A64_barrier_all -> 0 - | A64_barrier_LD -> 1 - | A64_barrier_ST -> 2 - end -end - -instance (EnumerationType barrier_kind) - let toNat = function - | Barrier_Sync () -> 0 - | Barrier_LwSync () -> 1 - | Barrier_Eieio () -> 2 - | Barrier_Isync () -> 3 - | Barrier_DMB (dom,typ) -> 4 + (toNat dom) + (4 * (toNat typ)) (* 4-15 *) - | Barrier_DSB (dom,typ) -> 16 + (toNat dom) + (4 * (toNat typ)) (* 16-27 *) - | Barrier_ISB () -> 28 - | Barrier_TM_COMMIT () -> 29 - | Barrier_MIPS_SYNC () -> 30 - | Barrier_RISCV_rw_rw () -> 31 - | Barrier_RISCV_r_rw () -> 32 - | Barrier_RISCV_r_r () -> 33 - | Barrier_RISCV_rw_w () -> 34 - | Barrier_RISCV_w_w () -> 35 - | Barrier_RISCV_w_rw () -> 36 - | Barrier_RISCV_rw_r () -> 37 - | Barrier_RISCV_r_w () -> 38 - | Barrier_RISCV_w_r () -> 39 - | Barrier_RISCV_tso () -> 40 - | Barrier_RISCV_i () -> 41 - | Barrier_x86_MFENCE () -> 42 - end -end diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 74e43a8f..3413494e 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -579,74 +579,13 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | Interp_ast.V_ctor (Id_aux (Id "NIAFP_indirect_address") _) _ _ _ -> NIA_indirect_address | _ -> failwith "Register footprint analysis did not return nia of expected type" end in - let readk_to_readk = function - | "Read_plain" -> Read_plain - | "Read_reserve" -> Read_reserve - | "Read_acquire" -> Read_acquire - | "Read_exclusive" -> Read_exclusive - | "Read_exclusive_acquire" -> Read_exclusive_acquire - | "Read_stream" -> Read_stream - | "Read_RISCV_acquire" -> Read_RISCV_acquire - | "Read_RISCV_strong_acquire" -> Read_RISCV_strong_acquire - | "Read_RISCV_reserved" -> Read_RISCV_reserved - | "Read_RISCV_reserved_acquire" -> Read_RISCV_reserved_acquire - | "Read_RISCV_reserved_strong_acquire" -> Read_RISCV_reserved_strong_acquire - | "Read_X86_locked" -> Read_X86_locked - | r -> failwith ("unknown read kind: " ^ r) end in - let writek_to_writek = function - | "Write_plain" -> Write_plain - | "Write_conditional" -> Write_conditional - | "Write_release" -> Write_release - | "Write_exclusive" -> Write_exclusive - | "Write_exclusive_release" -> Write_exclusive_release - | "Write_RISCV_release" -> Write_RISCV_release - | "Write_RISCV_strong_release" -> Write_RISCV_strong_release - | "Write_RISCV_conditional" -> Write_RISCV_conditional - | "Write_RISCV_conditional_release" -> Write_RISCV_conditional_release - | "Write_RISCV_conditional_strong_release" -> Write_RISCV_conditional_strong_release - | "Write_X86_locked" -> Write_X86_locked - | w -> failwith ("unknown write kind: " ^ w) end in - let ik_to_ik = function - | Interp_ast.V_ctor (Id_aux (Id "IK_barrier") _) _ _ - (Interp_ast.V_ctor (Id_aux (Id b) _) _ _ _) -> - IK_barrier (match b with - | "Barrier_Sync" -> Barrier_Sync - | "Barrier_LwSync" -> Barrier_LwSync - | "Barrier_Eieio" -> Barrier_Eieio - | "Barrier_Isync" -> Barrier_Isync - | "Barrier_DMB" -> Barrier_DMB - | "Barrier_DMB_ST" -> Barrier_DMB_ST - | "Barrier_DMB_LD" -> Barrier_DMB_LD - | "Barrier_DSB" -> Barrier_DSB - | "Barrier_DSB_ST" -> Barrier_DSB_ST - | "Barrier_DSB_LD" -> Barrier_DSB_LD - | "Barrier_ISB" -> Barrier_ISB - | "Barrier_MIPS_SYNC" -> Barrier_MIPS_SYNC - | "Barrier_x86_MFENCE" -> Barrier_x86_MFENCE - end) - | Interp_ast.V_ctor (Id_aux (Id "IK_mem_read") _) _ _ - (Interp_ast.V_ctor (Id_aux (Id r) _) _ _ _) -> - IK_mem_read(readk_to_readk r) - | Interp_ast.V_ctor (Id_aux (Id "IK_mem_write") _) _ _ - (Interp_ast.V_ctor (Id_aux (Id w) _) _ _ _) -> - IK_mem_write(writek_to_writek w) - | Interp_ast.V_ctor (Id_aux (Id "IK_mem_rmw") _) _ _ - (Interp_ast.V_tuple [(Interp_ast.V_ctor (Id_aux (Id readk) _) _ _ _) ; - (Interp_ast.V_ctor (Id_aux (Id writek) _) _ _ _)]) -> - IK_mem_rmw(readk_to_readk readk, writek_to_writek writek) - | Interp_ast.V_ctor (Id_aux (Id "IK_branch") _) _ _ _ -> - IK_branch - | Interp_ast.V_ctor (Id_aux (Id "IK_simple") _) _ _ _ -> - IK_simple - | _ -> failwith "Analysis returned unexpected instruction kind" - end in let (regs1,regs2,regs3,nias,dia,ik) = (List.map reg_to_reg_name regs1, List.map reg_to_reg_name regs2, List.map reg_to_reg_name regs3, List.map nia_to_nia nias, dia_to_dia dia, - ik_to_ik ik) in + fromInterpValue ik) in ((regs1,regs2,regs3,nias,dia,ik), events) | _ -> Assert_extra.failwith "Analysis did not return a four-tuple of lists" end) | Ivh_value_after_exn _ -> Assert_extra.failwith "Instruction analysis failed" diff --git a/src/lem_interp/sail2_instr_kinds.lem b/src/lem_interp/sail2_instr_kinds.lem index bd3a3eb7..f3cdfbc9 100644 --- a/src/lem_interp/sail2_instr_kinds.lem +++ b/src/lem_interp/sail2_instr_kinds.lem @@ -136,58 +136,86 @@ instance (Show write_kind) end end +type a64_barrier_domain = + A64_FullShare + | A64_InnerShare + | A64_OuterShare + | A64_NonShare + +type a64_barrier_type = + A64_barrier_all + | A64_barrier_LD + | A64_barrier_ST + type barrier_kind = (* Power barriers *) - Barrier_Sync | Barrier_LwSync | Barrier_Eieio | Barrier_Isync + Barrier_Sync of unit | Barrier_LwSync of unit | Barrier_Eieio of unit | Barrier_Isync of unit (* AArch64 barriers *) - | Barrier_DMB | Barrier_DMB_ST | Barrier_DMB_LD | Barrier_DSB - | Barrier_DSB_ST | Barrier_DSB_LD | Barrier_ISB - | Barrier_TM_COMMIT + | Barrier_DMB of (a64_barrier_domain * a64_barrier_type) + | Barrier_DSB of (a64_barrier_domain * a64_barrier_type) + | Barrier_ISB of unit + | Barrier_TM_COMMIT of unit (* MIPS barriers *) - | Barrier_MIPS_SYNC + | Barrier_MIPS_SYNC of unit (* RISC-V barriers *) - | Barrier_RISCV_rw_rw - | Barrier_RISCV_r_rw - | Barrier_RISCV_r_r - | Barrier_RISCV_rw_w - | Barrier_RISCV_w_w - | Barrier_RISCV_w_rw - | Barrier_RISCV_rw_r - | Barrier_RISCV_r_w - | Barrier_RISCV_w_r - | Barrier_RISCV_tso - | Barrier_RISCV_i + | Barrier_RISCV_rw_rw of unit + | Barrier_RISCV_r_rw of unit + | Barrier_RISCV_r_r of unit + | Barrier_RISCV_rw_w of unit + | Barrier_RISCV_w_w of unit + | Barrier_RISCV_w_rw of unit + | Barrier_RISCV_rw_r of unit + | Barrier_RISCV_r_w of unit + | Barrier_RISCV_w_r of unit + | Barrier_RISCV_tso of unit + | Barrier_RISCV_i of unit (* X86 *) - | Barrier_x86_MFENCE + | Barrier_x86_MFENCE of unit +let string_a64_barrier_domain = function + | A64_FullShare -> "A64_FullShare" + | A64_InnerShare -> "A64_InnerShare" + | A64_OuterShare -> "A64_OuterShare" + | A64_NonShare -> "A64_NonShare" +end + +instance (Show a64_barrier_domain) + let show = string_a64_barrier_domain +end + +let string_a64_barrier_type = function + | A64_barrier_all -> "A64_barrier_all" + | A64_barrier_LD -> "A64_barrier_LD" + | A64_barrier_ST -> "A64_barrier_ST" +end + +instance (Show a64_barrier_type) + let show = string_a64_barrier_type +end instance (Show barrier_kind) let show = function - | Barrier_Sync -> "Barrier_Sync" - | Barrier_LwSync -> "Barrier_LwSync" - | Barrier_Eieio -> "Barrier_Eieio" - | Barrier_Isync -> "Barrier_Isync" - | Barrier_DMB -> "Barrier_DMB" - | Barrier_DMB_ST -> "Barrier_DMB_ST" - | Barrier_DMB_LD -> "Barrier_DMB_LD" - | Barrier_DSB -> "Barrier_DSB" - | Barrier_DSB_ST -> "Barrier_DSB_ST" - | Barrier_DSB_LD -> "Barrier_DSB_LD" - | Barrier_ISB -> "Barrier_ISB" - | Barrier_TM_COMMIT -> "Barrier_TM_COMMIT" - | Barrier_MIPS_SYNC -> "Barrier_MIPS_SYNC" - | Barrier_RISCV_rw_rw -> "Barrier_RISCV_rw_rw" - | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" - | Barrier_RISCV_r_r -> "Barrier_RISCV_r_r" - | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" - | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" - | Barrier_RISCV_w_rw -> "Barrier_RISCV_w_rw" - | Barrier_RISCV_rw_r -> "Barrier_RISCV_rw_r" - | Barrier_RISCV_r_w -> "Barrier_RISCV_r_w" - | Barrier_RISCV_w_r -> "Barrier_RISCV_w_r" - | Barrier_RISCV_tso -> "Barrier_RISCV_tso" - | Barrier_RISCV_i -> "Barrier_RISCV_i" - | Barrier_x86_MFENCE -> "Barrier_x86_MFENCE" + | Barrier_Sync () -> "Barrier_Sync" + | Barrier_LwSync () -> "Barrier_LwSync" + | Barrier_Eieio () -> "Barrier_Eieio" + | Barrier_Isync () -> "Barrier_Isync" + | Barrier_DMB (dom,typ) -> "Barrier_DMB (" ^ (show dom) ^ ", " ^ (show typ) ^ ")" + | Barrier_DSB (dom,typ) -> "Barrier_DSB (" ^ (show dom) ^ ", " ^ (show typ) ^ ")" + | Barrier_ISB () -> "Barrier_ISB" + | Barrier_TM_COMMIT () -> "Barrier_TM_COMMIT" + | Barrier_MIPS_SYNC () -> "Barrier_MIPS_SYNC" + | Barrier_RISCV_rw_rw () -> "Barrier_RISCV_rw_rw" + | Barrier_RISCV_r_rw () -> "Barrier_RISCV_r_rw" + | Barrier_RISCV_r_r () -> "Barrier_RISCV_r_r" + | Barrier_RISCV_rw_w () -> "Barrier_RISCV_rw_w" + | Barrier_RISCV_w_w () -> "Barrier_RISCV_w_w" + | Barrier_RISCV_w_rw () -> "Barrier_RISCV_w_rw" + | Barrier_RISCV_rw_r () -> "Barrier_RISCV_rw_r" + | Barrier_RISCV_r_w () -> "Barrier_RISCV_r_w" + | Barrier_RISCV_w_r () -> "Barrier_RISCV_w_r" + | Barrier_RISCV_tso () -> "Barrier_RISCV_tso" + | Barrier_RISCV_i () -> "Barrier_RISCV_i" + | Barrier_x86_MFENCE () -> "Barrier_x86_MFENCE" end end @@ -304,32 +332,45 @@ instance (EnumerationType write_kind) end end +instance (EnumerationType a64_barrier_domain) + let toNat = function + | A64_FullShare -> 0 + | A64_InnerShare -> 1 + | A64_OuterShare -> 2 + | A64_NonShare -> 3 + end +end + +instance (EnumerationType a64_barrier_type) + let toNat = function + | A64_barrier_all -> 0 + | A64_barrier_LD -> 1 + | A64_barrier_ST -> 2 + end +end + instance (EnumerationType barrier_kind) let toNat = function - | Barrier_Sync -> 0 - | Barrier_LwSync -> 1 - | Barrier_Eieio ->2 - | Barrier_Isync -> 3 - | Barrier_DMB -> 4 - | Barrier_DMB_ST -> 5 - | Barrier_DMB_LD -> 6 - | Barrier_DSB -> 7 - | Barrier_DSB_ST -> 8 - | Barrier_DSB_LD -> 9 - | Barrier_ISB -> 10 - | Barrier_TM_COMMIT -> 11 - | Barrier_MIPS_SYNC -> 12 - | Barrier_RISCV_rw_rw -> 13 - | Barrier_RISCV_r_rw -> 14 - | Barrier_RISCV_r_r -> 15 - | Barrier_RISCV_rw_w -> 16 - | Barrier_RISCV_w_w -> 17 - | Barrier_RISCV_w_rw -> 18 - | Barrier_RISCV_rw_r -> 19 - | Barrier_RISCV_r_w -> 20 - | Barrier_RISCV_w_r -> 21 - | Barrier_RISCV_tso -> 22 - | Barrier_RISCV_i -> 23 - | Barrier_x86_MFENCE -> 24 + | Barrier_Sync () -> 0 + | Barrier_LwSync () -> 1 + | Barrier_Eieio () -> 2 + | Barrier_Isync () -> 3 + | Barrier_DMB (dom,typ) -> 4 + (toNat dom) + (4 * (toNat typ)) (* 4-15 *) + | Barrier_DSB (dom,typ) -> 16 + (toNat dom) + (4 * (toNat typ)) (* 16-27 *) + | Barrier_ISB () -> 28 + | Barrier_TM_COMMIT () -> 29 + | Barrier_MIPS_SYNC () -> 30 + | Barrier_RISCV_rw_rw () -> 31 + | Barrier_RISCV_r_rw () -> 32 + | Barrier_RISCV_r_r () -> 33 + | Barrier_RISCV_rw_w () -> 34 + | Barrier_RISCV_w_w () -> 35 + | Barrier_RISCV_w_rw () -> 36 + | Barrier_RISCV_rw_r () -> 37 + | Barrier_RISCV_r_w () -> 38 + | Barrier_RISCV_w_r () -> 39 + | Barrier_RISCV_tso () -> 40 + | Barrier_RISCV_i () -> 41 + | Barrier_x86_MFENCE () -> 42 end end -- cgit v1.2.3