From cc46b5a2366cd73d34117590448f6779fac4d312 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 17 Aug 2017 13:41:21 +0100 Subject: added RISC-V load-acquire --- src/lem_interp/sail_impl_base.lem | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index cda6702c..1642bc81 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -426,6 +426,8 @@ type read_kind = | Read_reserve (* AArch64 reads *) | Read_acquire | Read_exclusive | Read_exclusive_acquire | Read_stream + (* RISC-V reads *) + | Read_RISCV_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire instance (Show read_kind) let show = function -- cgit v1.2.3 From 9a26a0440f4d3c63ea19976c44cd39edb8149b2a Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sat, 19 Aug 2017 10:34:04 +0100 Subject: RISC-V store-release --- src/lem_interp/sail_impl_base.lem | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 1642bc81..caec3838 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -437,6 +437,9 @@ instance (Show read_kind) | Read_exclusive -> "Read_exclusive" | Read_exclusive_acquire -> "Read_exclusive_acquire" | Read_stream -> "Read_stream" + | Read_RISCV_acquire -> "Read_RISCV_acquire" + | Read_RISCV_reserved -> "Read_RISCV_reserved" + | Read_RISCV_reserved_acquire -> "Read_RISCV_reserved_acquire" end end @@ -447,6 +450,8 @@ type write_kind = | Write_conditional (* AArch64 writes *) | Write_release | Write_exclusive | Write_exclusive_release + (* RISC-V *) + | Write_RISCV_release | Write_RISCV_conditional | Write_RISCV_conditional_release instance (Show write_kind) let show = function @@ -455,6 +460,9 @@ instance (Show write_kind) | Write_release -> "Write_release" | Write_exclusive -> "Write_exclusive" | Write_exclusive_release -> "Write_exclusive_release" + | Write_RISCV_release -> "Write_RISCV_release" + | Write_RISCV_conditional -> "Write_RISCV_conditional" + | Write_RISCV_conditional_release -> "Write_RISCV_conditional_release" end end @@ -488,6 +496,9 @@ instance (Show barrier_kind) | 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_rw_w -> "Barrier_RISCV_rw_w" end end -- cgit v1.2.3 From 78a35c575021679b5e512539598d47603a6822f0 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 22 Aug 2017 11:09:47 +0100 Subject: adapt state.lem to RISCV additions --- src/gen_lib/state.lem | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 430ee562..2e29d19a 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -60,6 +60,9 @@ let read_mem dir read_kind addr sz state = | Sail_impl_base.Read_exclusive -> true | Sail_impl_base.Read_exclusive_acquire -> true | Sail_impl_base.Read_stream -> false + | Sail_impl_base.Read_RISCV_acquire -> false + | Sail_impl_base.Read_RISCV_reserved -> true + | Sail_impl_base.Read_RISCV_reserved_acquire -> true end in if is_exclusive -- cgit v1.2.3 From 6cc248cc27d9133e23da1454f115176f0799a572 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Tue, 22 Aug 2017 14:16:01 +0100 Subject: added RISC-V "fence w,w" and "fence.i"; fixed the interpreter nias analysis; --- src/lem_interp/interp_inter_imp.lem | 49 ++++++++++++++++++++++++++++++++++--- src/lem_interp/sail_impl_base.lem | 4 +++ 2 files changed, 49 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index fda9d5dd..6a9a77a1 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -1267,6 +1267,10 @@ let nias_of_instruction else [NIA_successor] | _ -> [ NIA_successor ] end + | ("PPCGEN_ism", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"PPCGEN_ism\", \"" ^ s ^ "\")") in + [ NIA_successor ] (* AARch64 label branch (i.e. address must be known) although these instructions take the address as an offset from PC, in here @@ -1301,7 +1305,10 @@ let nias_of_instruction | (Reg name _ _ _) -> name = n_reg | _ -> false end] - + | ("AArch64HandSail", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"AArch64HandSail\", \"" ^ s ^ "\")") in + [ NIA_successor ] (** hacky cut-and-paste for AArch64Gen, duplicating code just to see if this suffices *) @@ -1334,18 +1341,52 @@ let nias_of_instruction | (Reg name _ _ _) -> name = n_reg | _ -> false end] + | ("AArch64GenSail", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"AArch64GenSail\", \"" ^ s ^ "\")") in + [ NIA_successor ] (** end of hacky *) | ("AArch64LitmusSail", "CtrlDep") -> NIA_successor :: nias + | ("AArch64LitmusSail", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"AArch64LitmusSail\", \"" ^ s ^ "\")") in + [ NIA_successor ] | ("MIPS_ism", "B") -> fail + | ("MIPS_ism", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"MIPS_ism\", \"" ^ s ^ "\")") in + [ NIA_successor ] - | (s1,s2) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\""^s1^"\", \""^s2^"\")") in + | ("RISCV_ism", "JAL") -> nias + | ("RISCV_ism", "JALR") -> + let rs1_integer = + match instruction_fields with + | [_; (_, _, rs1); _] -> integer_of_bit_list rs1 + | _ -> fail + end + in + let () = ensure (0 <= rs1_integer && rs1_integer <= 31) + "expected register number from 0 to 31" + in + if rs1_integer = 0 then nias + else + let rs1_reg = "x" ^ (String_extra.stringFromInteger rs1_integer) in + [NIA_register r | forall (r MEM regs_in) + | match r with + | (Reg name _ _ _) -> name = rs1_reg + | _ -> false + end] + | ("RISCV_ism", "BTYPE") -> NIA_successor :: nias + | ("RISCV_ism", s) -> + let () = ensure (not unknown_nia_address) + ("unexpected unknown/undefined address in nia_values 4 (\"RISCV_ism\", \"" ^ s ^ "\")") in [ NIA_successor ] + + | (s1, s2) -> failwith ("unexpected (thread_ism, instruction_name): (" ^ s1 ^ ", " ^ s2 ^ ")") end let interp_instruction_analysis diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index caec3838..ebf0db4a 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -479,6 +479,8 @@ type barrier_kind = | Barrier_RISCV_rw_rw | Barrier_RISCV_r_rw | Barrier_RISCV_rw_w + | Barrier_RISCV_w_w + | Barrier_RISCV_i instance (Show barrier_kind) @@ -499,6 +501,8 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_rw -> "Barrier_RISCV_rw_rw" | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" + | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" + | Barrier_RISCV_I -> "Barrier_RISCV_i" end end -- cgit v1.2.3 From d8c238ddac07ed8bf828596ff68198d0c63758f5 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 22 Aug 2017 14:39:20 +0100 Subject: and fix that other places --- src/gen_lib/state.lem | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 2e29d19a..2ea1247e 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -47,25 +47,27 @@ let set_reg state reg bitv = <| state with regstate = Map.insert reg bitv state.regstate |> +let is_exclusive = function + | Sail_impl_base.Read_plain -> false + | Sail_impl_base.Read_reserve -> true + | Sail_impl_base.Read_acquire -> false + | Sail_impl_base.Read_exclusive -> true + | Sail_impl_base.Read_exclusive_acquire -> true + | Sail_impl_base.Read_stream -> false + | Sail_impl_base.Read_RISCV_acquire -> false + | Sail_impl_base.Read_RISCV_reserved -> true + | Sail_impl_base.Read_RISCV_reserved_acquire -> true +end + + val read_mem : bool -> read_kind -> vector bitU -> integer -> M (vector bitU) let read_mem dir read_kind addr sz state = let addr = integer_of_address (address_of_bitv addr) in let addrs = range addr (addr+sz-1) in let memory_value = List.map (fun addr -> Map_extra.find addr state.memstate) addrs in let value = Sail_values.internal_mem_value dir memory_value in - let is_exclusive = match read_kind with - | Sail_impl_base.Read_plain -> false - | Sail_impl_base.Read_reserve -> true - | Sail_impl_base.Read_acquire -> false - | Sail_impl_base.Read_exclusive -> true - | Sail_impl_base.Read_exclusive_acquire -> true - | Sail_impl_base.Read_stream -> false - | Sail_impl_base.Read_RISCV_acquire -> false - | Sail_impl_base.Read_RISCV_reserved -> true - | Sail_impl_base.Read_RISCV_reserved_acquire -> true - end in - if is_exclusive + if is_exclusive read_kind then [(Left value, <| state with last_exclusive_operation_was_load = true |>)] else [(Left value, state)] @@ -79,17 +81,8 @@ let read_tag dir read_kind addr state = | Just t -> t | Nothing -> B0 end in - let is_exclusive = match read_kind with - | Sail_impl_base.Read_plain -> false - | Sail_impl_base.Read_reserve -> true - | Sail_impl_base.Read_acquire -> false - | Sail_impl_base.Read_exclusive -> true - | Sail_impl_base.Read_exclusive_acquire -> true - | Sail_impl_base.Read_stream -> false - end in - (* TODO Should reading a tag set the exclusive flag? *) - if is_exclusive + if is_exclusive read_kind then [(Left tag, <| state with last_exclusive_operation_was_load = true |>)] else [(Left tag, state)] -- cgit v1.2.3 From 888b0f2bd01b8a2e026d6a081e85ffe2df3ed16c Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 24 Aug 2017 10:06:34 +0100 Subject: added barrier-kind for x86 MFENCE; fixed some compare functions; --- src/lem_interp/sail_impl_base.lem | 168 ++++++++++++++++++++++---------------- 1 file changed, 96 insertions(+), 72 deletions(-) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index ebf0db4a..b52eb58f 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -481,6 +481,8 @@ type barrier_kind = | Barrier_RISCV_rw_w | Barrier_RISCV_w_w | Barrier_RISCV_i + (* X86 *) + | Barrier_X86_MFENCE instance (Show barrier_kind) @@ -503,6 +505,7 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" | Barrier_RISCV_I -> "Barrier_RISCV_i" + | Barrier_X86_MFENCE -> "Barrier_X86_MFENCE" end end @@ -546,48 +549,42 @@ end let ~{ocaml} read_kindCompare rk1 rk2 = match (rk1, rk2) with - | (Read_plain, Read_plain) -> EQ - | (Read_plain, Read_reserve) -> LT - | (Read_plain, Read_acquire) -> LT - | (Read_plain, Read_exclusive) -> LT - | (Read_plain, Read_exclusive_acquire) -> LT - | (Read_plain, Read_stream) -> LT - - | (Read_reserve, Read_plain) -> GT - | (Read_reserve, Read_reserve) -> EQ - | (Read_reserve, Read_acquire) -> LT - | (Read_reserve, Read_exclusive) -> LT - | (Read_reserve, Read_exclusive_acquire) -> LT - | (Read_reserve, Read_stream) -> LT - - | (Read_acquire, Read_plain) -> GT - | (Read_acquire, Read_reserve) -> GT - | (Read_acquire, Read_acquire) -> EQ - | (Read_acquire, Read_exclusive) -> LT - | (Read_acquire, Read_exclusive_acquire) -> LT - | (Read_acquire, Read_stream) -> LT - - | (Read_exclusive, Read_plain) -> GT - | (Read_exclusive, Read_reserve) -> GT - | (Read_exclusive, Read_acquire) -> GT - | (Read_exclusive, Read_exclusive) -> EQ - | (Read_exclusive, Read_exclusive_acquire) -> LT - | (Read_exclusive, Read_stream) -> LT - - | (Read_exclusive_acquire, Read_plain) -> GT - | (Read_exclusive_acquire, Read_reserve) -> GT - | (Read_exclusive_acquire, Read_acquire) -> GT - | (Read_exclusive_acquire, Read_exclusive) -> GT + | (Read_plain, Read_plain) -> EQ + | (Read_plain, _) -> LT + | (_, Read_plain) -> GT + + | (Read_reserve, Read_reserve) -> EQ + | (Read_reserve, _) -> LT + | (_, Read_reserve) -> GT + + | (Read_acquire, Read_acquire) -> EQ + | (Read_acquire, _) -> LT + | (_, Read_acquire) -> GT + + | (Read_exclusive, Read_exclusive) -> EQ + | (Read_exclusive, _) -> LT + | (_, Read_exclusive) -> GT + | (Read_exclusive_acquire, Read_exclusive_acquire) -> EQ - | (Read_exclusive_acquire, Read_stream) -> GT - - | (Read_stream, Read_plain) -> GT - | (Read_stream, Read_reserve) -> GT - | (Read_stream, Read_acquire) -> GT - | (Read_stream, Read_exclusive) -> GT - | (Read_stream, Read_exclusive_acquire) -> GT - | (Read_stream, Read_stream) -> EQ -end + | (Read_exclusive_acquire, _) -> LT + | (_, Read_exclusive_acquire) -> GT + + | (Read_stream, Read_stream) -> EQ + | (Read_stream, _) -> LT + | (_, Read_stream) -> GT + + | (Read_RISCV_acquire, Read_RISCV_acquire) -> EQ + | (Read_RISCV_acquire, _) -> LT + | (_, Read_RISCV_acquire) -> GT + + | (Read_RISCV_reserved, Read_RISCV_reserved) -> EQ + | (Read_RISCV_reserved, _) -> LT + | (_, Read_RISCV_reserved) -> GT + + | (Read_RISCV_reserved_acquire, Read_RISCV_reserved_acquire) -> EQ + (*| (Read_RISCV_reserved_acquire, _) -> LT + | (_, Read_RISCV_reserved_acquire) -> GT*) + end let inline {ocaml} read_kindCompare = defaultCompare let ~{ocaml} read_kindLess b1 b2 = read_kindCompare b1 b2 = LT @@ -610,36 +607,39 @@ end let ~{ocaml} write_kindCompare wk1 wk2 = match (wk1, wk2) with - | (Write_plain, Write_plain) -> EQ - | (Write_plain, Write_conditional) -> LT - | (Write_plain, Write_release) -> LT - | (Write_plain, Write_exclusive) -> LT - | (Write_plain, Write_exclusive_release) -> LT - - | (Write_conditional, Write_plain) -> GT - | (Write_conditional, Write_conditional) -> EQ - | (Write_conditional, Write_release) -> LT - | (Write_conditional, Write_exclusive) -> LT - | (Write_conditional, Write_exclusive_release) -> LT - - | (Write_release, Write_plain) -> GT - | (Write_release, Write_conditional) -> GT - | (Write_release, Write_release) -> EQ - | (Write_release, Write_exclusive) -> LT - | (Write_release, Write_exclusive_release) -> LT - - | (Write_exclusive, Write_plain) -> GT - | (Write_exclusive, Write_conditional) -> GT - | (Write_exclusive, Write_release) -> GT - | (Write_exclusive, Write_exclusive) -> EQ - | (Write_exclusive, Write_exclusive_release) -> LT - - | (Write_exclusive_release, Write_plain) -> GT - | (Write_exclusive_release, Write_conditional) -> GT - | (Write_exclusive_release, Write_release) -> GT - | (Write_exclusive_release, Write_exclusive) -> GT + | (Write_plain, Write_plain) -> EQ + | (Write_plain, _) -> LT + | (_, Write_plain) -> GT + + | (Write_conditional, Write_conditional) -> EQ + | (Write_conditional, _) -> LT + | (_, Write_conditional) -> GT + + + | (Write_release, Write_release) -> EQ + | (Write_release, _) -> LT + | (_, Write_release) -> GT + + | (Write_exclusive, Write_exclusive) -> EQ + | (Write_exclusive, _) -> LT + | (_, Write_exclusive) -> GT + | (Write_exclusive_release, Write_exclusive_release) -> EQ -end + | (Write_exclusive_release, _) -> LT + | (_, Write_exclusive_release) -> GT + + | (Write_RISCV_release, Write_RISCV_release) -> EQ + | (Write_RISCV_release, _) -> LT + | (_, Write_RISCV_release) -> GT + + | (Write_RISCV_conditional, Write_RISCV_conditional) -> EQ + | (Write_RISCV_conditional, _) -> LT + | (_, Write_RISCV_conditional) -> GT + + | (Write_RISCV_conditional_release, Write_RISCV_conditional_release) -> EQ + (*| (Write_RISCV_conditional_release, _) -> LT + | (_, Write_RISCV_conditional_release) -> GT*) + end let inline {ocaml} write_kindCompare = defaultCompare let ~{ocaml} write_kindLess b1 b2 = write_kindCompare b1 b2 = LT @@ -660,6 +660,7 @@ instance (Ord write_kind) let (>=) = write_kindGreaterEq end + let ~{ocaml} barrier_kindCompare bk1 bk2 = match (bk1, bk2) with | (Barrier_Sync, Barrier_Sync) -> EQ @@ -711,9 +712,32 @@ let ~{ocaml} barrier_kindCompare bk1 bk2 = | (_, Barrier_TM_COMMIT) -> GT | (Barrier_MIPS_SYNC, Barrier_MIPS_SYNC) -> EQ - (* | (Barrier_MIPS_SYNC, _) -> LT - | (_, Barrier_MIPS_SYNC) -> GT *) + | (Barrier_MIPS_SYNC, _) -> LT + | (_, Barrier_MIPS_SYNC) -> GT + + | (Barrier_RISCV_rw_rw, Barrier_RISCV_rw_rw) -> EQ + | (Barrier_RISCV_rw_rw, _) -> LT + | (_, Barrier_RISCV_rw_rw) -> GT + + | (Barrier_RISCV_r_rw, Barrier_RISCV_r_rw) -> EQ + | (Barrier_RISCV_r_rw, _) -> LT + | (_, Barrier_RISCV_r_rw) -> GT + + | (Barrier_RISCV_rw_w, Barrier_RISCV_rw_w) -> EQ + | (Barrier_RISCV_rw_w, _) -> LT + | (_, Barrier_RISCV_rw_w) -> GT + + | (Barrier_RISCV_w_w, Barrier_RISCV_w_w) -> EQ + | (Barrier_RISCV_w_w, _) -> LT + | (_, Barrier_RISCV_w_w) -> GT + + | (Barrier_RISCV_i, Barrier_RISCV_i) -> EQ + | (Barrier_RISCV_i, _) -> LT + | (_, Barrier_RISCV_i) -> GT + | (Barrier_X86_MFENCE, Barrier_X86_MFENCE) -> EQ + (*| (Barrier_X86_MFENCE, _) -> LT + | (_, Barrier_X86_MFENCE) -> GT*) end let inline {ocaml} barrier_kindCompare = defaultCompare -- cgit v1.2.3 From 3721093caa882173526ab7ba03ccaa3226e2a94f Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 24 Aug 2017 10:09:00 +0100 Subject: typo --- src/lem_interp/sail_impl_base.lem | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index b52eb58f..60beffb4 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -504,7 +504,7 @@ instance (Show barrier_kind) | Barrier_RISCV_r_rw -> "Barrier_RISCV_r_rw" | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" - | Barrier_RISCV_I -> "Barrier_RISCV_i" + | Barrier_RISCV_i -> "Barrier_RISCV_i" | Barrier_X86_MFENCE -> "Barrier_X86_MFENCE" end end -- cgit v1.2.3 From 1dd42197633a1b608303187fac8cc7f5b30ec22e Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 24 Aug 2017 10:11:22 +0100 Subject: typo --- src/lem_interp/sail_impl_base.lem | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 60beffb4..65ae87c2 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -482,7 +482,7 @@ type barrier_kind = | Barrier_RISCV_w_w | Barrier_RISCV_i (* X86 *) - | Barrier_X86_MFENCE + | Barrier_x86_MFENCE instance (Show barrier_kind) @@ -505,7 +505,7 @@ instance (Show barrier_kind) | Barrier_RISCV_rw_w -> "Barrier_RISCV_rw_w" | Barrier_RISCV_w_w -> "Barrier_RISCV_w_w" | Barrier_RISCV_i -> "Barrier_RISCV_i" - | Barrier_X86_MFENCE -> "Barrier_X86_MFENCE" + | Barrier_x86_MFENCE -> "Barrier_x86_MFENCE" end end @@ -735,9 +735,9 @@ let ~{ocaml} barrier_kindCompare bk1 bk2 = | (Barrier_RISCV_i, _) -> LT | (_, Barrier_RISCV_i) -> GT - | (Barrier_X86_MFENCE, Barrier_X86_MFENCE) -> EQ - (*| (Barrier_X86_MFENCE, _) -> LT - | (_, Barrier_X86_MFENCE) -> GT*) + | (Barrier_x86_MFENCE, Barrier_x86_MFENCE) -> EQ + (*| (Barrier_x86_MFENCE, _) -> LT + | (_, Barrier_x86_MFENCE) -> GT*) end let inline {ocaml} barrier_kindCompare = defaultCompare -- cgit v1.2.3 From d9e3c14533806986f7c6ce843148cf1973f9711b Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Wed, 30 Aug 2017 14:44:28 +0100 Subject: typeclass instance Ord(opcode) --- src/lem_interp/sail_impl_base.lem | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 65ae87c2..3886f919 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -110,7 +110,7 @@ type address = Address of list byte (* of length 8 *) * integer type opcode = Opcode of list byte (* of length 4 *) (** typeclass instantiations *) - + let ~{ocaml} bitCompare (b1:bit) (b2:bit) = match (b1,b2) with | (Bitc_zero, Bitc_zero) -> EQ @@ -214,6 +214,36 @@ instance (Ord byte) 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 *) -- cgit v1.2.3 From 07fad742df72ff6e7bfb948c1c353a2cf12f5e28 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 31 Aug 2017 15:08:10 +0100 Subject: added RISC-V AMOs --- src/lem_interp/interp_inter_imp.lem | 39 ++++++++++++++++++++++++++++++++++++- src/lem_interp/sail_impl_base.lem | 25 ++++++++++++------------ 2 files changed, 51 insertions(+), 13 deletions(-) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 6a9a77a1..411ad3fc 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -1416,6 +1416,41 @@ let interp_instruction_analysis 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_cond_branch -> false + | IK_trans _ -> false + | IK_simple -> false + end) && + (exists (inst_kind' MEM (inst_kind :: inst_kinds)). + match inst_kind' with + | IK_mem_read _ -> true + | _ -> false + end) && + (exists (inst_kind' MEM (inst_kind :: inst_kinds)). + match inst_kind' with + | IK_mem_write _ -> true + | _ -> 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) && @@ -1424,7 +1459,9 @@ let interp_instruction_analysis || inst_kind' = IK_trans Transaction_abort) then IK_trans Transaction_start - else failwith "multiple instruction kinds" + + else + failwith "multiple instruction kinds" end in (regs_in, regs_out, regs_feeding_address, nias, dia, inst_kind) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 3886f919..721c0226 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -552,26 +552,27 @@ instance (Show trans_kind) end type instruction_kind = - | IK_barrier of barrier_kind - | IK_mem_read of read_kind + | IK_barrier of barrier_kind + | IK_mem_read of read_kind | IK_mem_write of write_kind -(* SS reinstating cond_branches -at present branches are not distinguished in the instruction_kind; -they just have particular nias (and will be IK_simple *) - | IK_cond_branch -(* | IK_uncond_branch *) - | IK_trans of trans_kind + | IK_mem_rmw of (read_kind * write_kind) + | IK_cond_branch + (* unconditional branches are not distinguished in the instruction_kind; + they just have particular nias (and will be IK_simple *) + (* | IK_uncond_branch *) + | IK_trans of trans_kind | IK_simple 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_read read_kind -> "IK_mem_read " ^ (show read_kind) | IK_mem_write write_kind -> "IK_mem_write " ^ (show write_kind) - | IK_cond_branch -> "IK_cond_branch" - | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) - | IK_simple -> "IK_simple" + | IK_mem_rmw (r, w) -> "IK_mem_rmw " ^ (show r) ^ " " ^ (show w) + | IK_cond_branch -> "IK_cond_branch" + | IK_trans trans_kind -> "IK_trans " ^ (show trans_kind) + | IK_simple -> "IK_simple" end end -- cgit v1.2.3 From f83c3d00f60a2507dfa5c3f31de6ddfc08eee610 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Thu, 31 Aug 2017 17:25:30 +0100 Subject: add EnumerationType type class: if a type is a member you get Ord membership and Set membership for free --- src/lem_interp/sail_impl_base.lem | 361 ++++++++++---------------------------- 1 file changed, 89 insertions(+), 272 deletions(-) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 721c0226..c577c44b 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -42,6 +42,29 @@ 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 + + + (* 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 @@ -111,65 +134,21 @@ type opcode = Opcode of list byte (* of length 4 *) (** typeclass instantiations *) -let ~{ocaml} bitCompare (b1:bit) (b2:bit) = - match (b1,b2) with - | (Bitc_zero, Bitc_zero) -> EQ - | (Bitc_one, Bitc_one) -> EQ - | (Bitc_zero, _) -> LT - | (_,_) -> GT + +instance (EnumerationType bit) + let toNat = function + | Bitc_zero -> 0 + | Bitc_one -> 1 end -let inline {ocaml} bitCompare = defaultCompare - -let ~{ocaml} bitLess b1 b2 = bitCompare b1 b2 = LT -let ~{ocaml} bitLessEq b1 b2 = bitCompare b1 b2 <> GT -let ~{ocaml} bitGreater b1 b2 = bitCompare b1 b2 = GT -let ~{ocaml} bitGreaterEq b1 b2 = bitCompare b1 b2 <> LT - -let inline {ocaml} bitLess = defaultLess -let inline {ocaml} bitLessEq = defaultLessEq -let inline {ocaml} bitGreater = defaultGreater -let inline {ocaml} bitGreaterEq = defaultGreaterEq - -instance (Ord bit) - let compare = bitCompare - let (<) = bitLess - let (<=) = bitLessEq - let (>) = bitGreater - let (>=) = bitGreaterEq end -let ~{ocaml} bit_liftedCompare (bl1:bit_lifted) (bl2:bit_lifted) = - match (bl1,bl2) with - | (Bitl_zero, Bitl_zero) -> EQ - | (Bitl_zero,_) -> LT - | (Bitl_one, Bitl_zero) -> GT - | (Bitl_one, Bitl_one) -> EQ - | (Bitl_one, _) -> LT - | (Bitl_undef,Bitl_zero) -> GT - | (Bitl_undef,Bitl_one) -> GT - | (Bitl_undef,Bitl_undef) -> EQ - | (Bitl_undef,_) -> LT - | (Bitl_unknown,Bitl_unknown) -> EQ - | (Bitl_unknown,_) -> GT +instance (EnumerationType bit_lifted) + let toNat = function + | Bitl_zero -> 0 + | Bitl_one -> 1 + | Bitl_undef -> 2 + | Bitl_unknown -> 3 end -let inline {ocaml} bit_liftedCompare = defaultCompare - -let ~{ocaml} bit_liftedLess b1 b2 = bit_liftedCompare b1 b2 = LT -let ~{ocaml} bit_liftedLessEq b1 b2 = bit_liftedCompare b1 b2 <> GT -let ~{ocaml} bit_liftedGreater b1 b2 = bit_liftedCompare b1 b2 = GT -let ~{ocaml} bit_liftedGreaterEq b1 b2 = bit_liftedCompare b1 b2 <> LT - -let inline {ocaml} bit_liftedLess = defaultLess -let inline {ocaml} bit_liftedLessEq = defaultLessEq -let inline {ocaml} bit_liftedGreater = defaultGreater -let inline {ocaml} bit_liftedGreaterEq = defaultGreaterEq - -instance (Ord bit_lifted) - let compare = bit_liftedCompare - let (<) = bit_liftedLess - let (<=) = bit_liftedLessEq - let (>) = bit_liftedGreater - let (>=) = bit_liftedGreaterEq end let ~{ocaml} byte_liftedCompare (Byte_lifted b1) (Byte_lifted b2) = compare b1 b2 @@ -578,233 +557,71 @@ end -let ~{ocaml} read_kindCompare rk1 rk2 = - match (rk1, rk2) with - | (Read_plain, Read_plain) -> EQ - | (Read_plain, _) -> LT - | (_, Read_plain) -> GT - - | (Read_reserve, Read_reserve) -> EQ - | (Read_reserve, _) -> LT - | (_, Read_reserve) -> GT - - | (Read_acquire, Read_acquire) -> EQ - | (Read_acquire, _) -> LT - | (_, Read_acquire) -> GT - - | (Read_exclusive, Read_exclusive) -> EQ - | (Read_exclusive, _) -> LT - | (_, Read_exclusive) -> GT - - | (Read_exclusive_acquire, Read_exclusive_acquire) -> EQ - | (Read_exclusive_acquire, _) -> LT - | (_, Read_exclusive_acquire) -> GT - - | (Read_stream, Read_stream) -> EQ - | (Read_stream, _) -> LT - | (_, Read_stream) -> GT - - | (Read_RISCV_acquire, Read_RISCV_acquire) -> EQ - | (Read_RISCV_acquire, _) -> LT - | (_, Read_RISCV_acquire) -> GT - - | (Read_RISCV_reserved, Read_RISCV_reserved) -> EQ - | (Read_RISCV_reserved, _) -> LT - | (_, Read_RISCV_reserved) -> GT - - | (Read_RISCV_reserved_acquire, Read_RISCV_reserved_acquire) -> EQ - (*| (Read_RISCV_reserved_acquire, _) -> LT - | (_, Read_RISCV_reserved_acquire) -> GT*) +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_reserved -> 7 + | Read_RISCV_reserved_acquire -> 8 end -let inline {ocaml} read_kindCompare = defaultCompare - -let ~{ocaml} read_kindLess b1 b2 = read_kindCompare b1 b2 = LT -let ~{ocaml} read_kindLessEq b1 b2 = read_kindCompare b1 b2 <> GT -let ~{ocaml} read_kindGreater b1 b2 = read_kindCompare b1 b2 = GT -let ~{ocaml} read_kindGreaterEq b1 b2 = read_kindCompare b1 b2 <> LT - -let inline {ocaml} read_kindLess = defaultLess -let inline {ocaml} read_kindLessEq = defaultLessEq -let inline {ocaml} read_kindGreater = defaultGreater -let inline {ocaml} read_kindGreaterEq = defaultGreaterEq - -instance (Ord read_kind) - let compare = read_kindCompare - let (<) = read_kindLess - let (<=) = read_kindLessEq - let (>) = read_kindGreater - let (>=) = read_kindGreaterEq end -let ~{ocaml} write_kindCompare wk1 wk2 = - match (wk1, wk2) with - | (Write_plain, Write_plain) -> EQ - | (Write_plain, _) -> LT - | (_, Write_plain) -> GT - - | (Write_conditional, Write_conditional) -> EQ - | (Write_conditional, _) -> LT - | (_, Write_conditional) -> GT - - - | (Write_release, Write_release) -> EQ - | (Write_release, _) -> LT - | (_, Write_release) -> GT - - | (Write_exclusive, Write_exclusive) -> EQ - | (Write_exclusive, _) -> LT - | (_, Write_exclusive) -> GT - - | (Write_exclusive_release, Write_exclusive_release) -> EQ - | (Write_exclusive_release, _) -> LT - | (_, Write_exclusive_release) -> GT - - | (Write_RISCV_release, Write_RISCV_release) -> EQ - | (Write_RISCV_release, _) -> LT - | (_, Write_RISCV_release) -> GT - - | (Write_RISCV_conditional, Write_RISCV_conditional) -> EQ - | (Write_RISCV_conditional, _) -> LT - | (_, Write_RISCV_conditional) -> GT - - | (Write_RISCV_conditional_release, Write_RISCV_conditional_release) -> EQ - (*| (Write_RISCV_conditional_release, _) -> LT - | (_, Write_RISCV_conditional_release) -> GT*) +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_conditional -> 6 + | Write_RISCV_conditional_release -> 7 end -let inline {ocaml} write_kindCompare = defaultCompare - -let ~{ocaml} write_kindLess b1 b2 = write_kindCompare b1 b2 = LT -let ~{ocaml} write_kindLessEq b1 b2 = write_kindCompare b1 b2 <> GT -let ~{ocaml} write_kindGreater b1 b2 = write_kindCompare b1 b2 = GT -let ~{ocaml} write_kindGreaterEq b1 b2 = write_kindCompare b1 b2 <> LT - -let inline {ocaml} write_kindLess = defaultLess -let inline {ocaml} write_kindLessEq = defaultLessEq -let inline {ocaml} write_kindGreater = defaultGreater -let inline {ocaml} write_kindGreaterEq = defaultGreaterEq - -instance (Ord write_kind) - let compare = write_kindCompare - let (<) = write_kindLess - let (<=) = write_kindLessEq - let (>) = write_kindGreater - let (>=) = write_kindGreaterEq end - -let ~{ocaml} barrier_kindCompare bk1 bk2 = - match (bk1, bk2) with - | (Barrier_Sync, Barrier_Sync) -> EQ - | (Barrier_Sync, _) -> LT - | (_, Barrier_Sync) -> GT - - | (Barrier_LwSync, Barrier_LwSync) -> EQ - | (Barrier_LwSync, _) -> LT - | (_, Barrier_LwSync) -> GT - - | (Barrier_Eieio, Barrier_Eieio) -> EQ - | (Barrier_Eieio, _) -> LT - | (_, Barrier_Eieio) -> GT - - | (Barrier_Isync, Barrier_Isync) -> EQ - | (Barrier_Isync, _) -> LT - | (_, Barrier_Isync) -> GT - - | (Barrier_DMB, Barrier_DMB) -> EQ - | (Barrier_DMB, _) -> LT - | (_, Barrier_DMB) -> GT - - | (Barrier_DMB_ST, Barrier_DMB_ST) -> EQ - | (Barrier_DMB_ST, _) -> LT - | (_, Barrier_DMB_ST) -> GT - - | (Barrier_DMB_LD, Barrier_DMB_LD) -> EQ - | (Barrier_DMB_LD, _) -> LT - | (_, Barrier_DMB_LD) -> GT - - | (Barrier_DSB, Barrier_DSB) -> EQ - | (Barrier_DSB, _) -> LT - | (_, Barrier_DSB) -> GT - - | (Barrier_DSB_ST, Barrier_DSB_ST) -> EQ - | (Barrier_DSB_ST, _) -> LT - | (_, Barrier_DSB_ST) -> GT - - | (Barrier_DSB_LD, Barrier_DSB_LD) -> EQ - | (Barrier_DSB_LD, _) -> LT - | (_, Barrier_DSB_LD) -> GT - - | (Barrier_ISB, Barrier_ISB) -> EQ - | (Barrier_ISB, _) -> LT - | (_, Barrier_ISB) -> GT - - | (Barrier_TM_COMMIT, Barrier_TM_COMMIT) -> EQ - | (Barrier_TM_COMMIT, _) -> LT - | (_, Barrier_TM_COMMIT) -> GT - - | (Barrier_MIPS_SYNC, Barrier_MIPS_SYNC) -> EQ - | (Barrier_MIPS_SYNC, _) -> LT - | (_, Barrier_MIPS_SYNC) -> GT - - | (Barrier_RISCV_rw_rw, Barrier_RISCV_rw_rw) -> EQ - | (Barrier_RISCV_rw_rw, _) -> LT - | (_, Barrier_RISCV_rw_rw) -> GT - - | (Barrier_RISCV_r_rw, Barrier_RISCV_r_rw) -> EQ - | (Barrier_RISCV_r_rw, _) -> LT - | (_, Barrier_RISCV_r_rw) -> GT - - | (Barrier_RISCV_rw_w, Barrier_RISCV_rw_w) -> EQ - | (Barrier_RISCV_rw_w, _) -> LT - | (_, Barrier_RISCV_rw_w) -> GT - - | (Barrier_RISCV_w_w, Barrier_RISCV_w_w) -> EQ - | (Barrier_RISCV_w_w, _) -> LT - | (_, Barrier_RISCV_w_w) -> GT - - | (Barrier_RISCV_i, Barrier_RISCV_i) -> EQ - | (Barrier_RISCV_i, _) -> LT - | (_, Barrier_RISCV_i) -> GT - - | (Barrier_x86_MFENCE, Barrier_x86_MFENCE) -> EQ - (*| (Barrier_x86_MFENCE, _) -> LT - | (_, Barrier_x86_MFENCE) -> GT*) +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_rw_w -> 15 + | Barrier_RISCV_w_w -> 16 + | Barrier_RISCV_i -> 17 + | Barrier_x86_MFENCE -> 18 end -let inline {ocaml} barrier_kindCompare = defaultCompare - -let ~{ocaml} barrier_kindLess b1 b2 = barrier_kindCompare b1 b2 = LT -let ~{ocaml} barrier_kindLessEq b1 b2 = barrier_kindCompare b1 b2 <> GT -let ~{ocaml} barrier_kindGreater b1 b2 = barrier_kindCompare b1 b2 = GT -let ~{ocaml} barrier_kindGreaterEq b1 b2 = barrier_kindCompare b1 b2 <> LT - -let inline {ocaml} barrier_kindLess = defaultLess -let inline {ocaml} barrier_kindLessEq = defaultLessEq -let inline {ocaml} barrier_kindGreater = defaultGreater -let inline {ocaml} barrier_kindGreaterEq = defaultGreaterEq - -instance (Ord barrier_kind) - let compare = barrier_kindCompare - let (<) = barrier_kindLess - let (<=) = barrier_kindLessEq - let (>) = barrier_kindGreater - let (>=) = barrier_kindGreaterEq end - 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 + | 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 = -- cgit v1.2.3 From 75022d46352525305b4c06b4988bf2df15f9f29e Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Sun, 3 Sep 2017 15:05:23 +0100 Subject: added RISC-V strong-acquire/release --- src/gen_lib/sail_values.lem | 3 +++ src/gen_lib/state.lem | 2 ++ src/lem_interp/sail_impl_base.lem | 24 ++++++++++++++++++------ 3 files changed, 23 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/gen_lib/sail_values.lem b/src/gen_lib/sail_values.lem index 49f37381..121f6cc8 100644 --- a/src/gen_lib/sail_values.lem +++ b/src/gen_lib/sail_values.lem @@ -956,3 +956,6 @@ let diafp_to_dia reginfo = function | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv v) | DIAFP_reg r -> DIA_register (regfp_to_reg reginfo r) end + +let max = uncurry max +let min = uncurry min diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index 2ea1247e..ac5cb869 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -55,8 +55,10 @@ let is_exclusive = function | Sail_impl_base.Read_exclusive_acquire -> true | Sail_impl_base.Read_stream -> false | Sail_impl_base.Read_RISCV_acquire -> false + | Sail_impl_base.Read_RISCV_strong_acquire -> false | Sail_impl_base.Read_RISCV_reserved -> true | Sail_impl_base.Read_RISCV_reserved_acquire -> true + | Sail_impl_base.Read_RISCV_reserved_strong_acquire -> true end diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index c577c44b..48ddd10e 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -436,7 +436,9 @@ type read_kind = (* AArch64 reads *) | Read_acquire | Read_exclusive | Read_exclusive_acquire | Read_stream (* RISC-V reads *) - | Read_RISCV_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire + | Read_RISCV_acquire | Read_RISCV_strong_acquire + | Read_RISCV_reserved | Read_RISCV_reserved_acquire + | Read_RISCV_reserved_strong_acquire instance (Show read_kind) let show = function @@ -447,8 +449,10 @@ instance (Show read_kind) | 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" end end @@ -460,7 +464,9 @@ type write_kind = (* AArch64 writes *) | Write_release | Write_exclusive | Write_exclusive_release (* RISC-V *) - | Write_RISCV_release | Write_RISCV_conditional | Write_RISCV_conditional_release + | Write_RISCV_release | Write_RISCV_strong_release + | Write_RISCV_conditional | Write_RISCV_conditional_release + | Write_RISCV_conditional_strong_release instance (Show write_kind) let show = function @@ -470,8 +476,10 @@ instance (Show write_kind) | 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" end end @@ -566,8 +574,10 @@ instance (EnumerationType read_kind) | Read_exclusive_acquire -> 4 | Read_stream -> 5 | Read_RISCV_acquire -> 6 - | Read_RISCV_reserved -> 7 - | Read_RISCV_reserved_acquire -> 8 + | Read_RISCV_strong_acquire -> 7 + | Read_RISCV_reserved -> 8 + | Read_RISCV_reserved_acquire -> 9 + | Read_RISCV_reserved_strong_acquire -> 10 end end @@ -579,8 +589,10 @@ instance (EnumerationType write_kind) | Write_exclusive -> 3 | Write_exclusive_release -> 4 | Write_RISCV_release -> 5 - | Write_RISCV_conditional -> 6 - | Write_RISCV_conditional_release -> 7 + | Write_RISCV_strong_release -> 6 + | Write_RISCV_conditional -> 7 + | Write_RISCV_conditional_release -> 8 + | Write_RISCV_conditional_strong_release -> 9 end end -- cgit v1.2.3 From a97cd6081df6a76c9daa34c773d82f21f5d014c8 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 15 Sep 2017 11:50:54 +0100 Subject: reinstate deep/shallow conversion --- src/gen_lib/deep_shallow_convert.lem | 116 ++++++++++++--------- src/lem_interp/sail_impl_base.lem | 2 + src/pretty_print.mli | 2 +- src/pretty_print_lem.ml | 191 +++++++++++++++++------------------ src/process_file.ml | 13 ++- 5 files changed, 176 insertions(+), 148 deletions(-) (limited to 'src') diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 23c34222..4af6eb2f 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -6,20 +6,20 @@ open import Sail_values class (ToFromInterpValue 'a) - val toInterpValue : 'a -> Interp.value - val fromInterpValue : Interp.value -> 'a + val toInterpValue : 'a -> Interp_ast.value + val fromInterpValue : Interp_ast.value -> 'a end let toInterValueBool = function - | true -> Interp.V_lit (L_aux (L_one) Unknown) - | false -> Interp.V_lit (L_aux (L_zero) Unknown) + | true -> Interp_ast.V_lit (L_aux (L_one) Unknown) + | false -> Interp_ast.V_lit (L_aux (L_zero) Unknown) end let rec fromInterpValueBool v = match v with - | Interp.V_lit (L_aux (L_true) _) -> true - | Interp.V_lit (L_aux (L_false) _) -> false - | Interp.V_lit (L_aux (L_one) _) -> true - | Interp.V_lit (L_aux (L_zero) _) -> false - | Interp.V_tuple [v] -> fromInterpValueBool v + | Interp_ast.V_lit (L_aux (L_true) _) -> true + | Interp_ast.V_lit (L_aux (L_false) _) -> false + | Interp_ast.V_lit (L_aux (L_one) _) -> true + | Interp_ast.V_lit (L_aux (L_zero) _) -> false + | Interp_ast.V_tuple [v] -> fromInterpValueBool v | v -> failwith ("fromInterpValue bool: unexpected value. " ^ Interp.debug_print_value v) end @@ -29,10 +29,10 @@ instance (ToFromInterpValue bool) end -let toInterpValueUnit () = Interp.V_lit (L_aux (L_unit) Unknown) +let toInterpValueUnit () = Interp_ast.V_lit (L_aux (L_unit) Unknown) let rec fromInterpValueUnit v = match v with - | Interp.V_lit (L_aux (L_unit) _) -> () - | Interp.V_tuple [v] -> fromInterpValueUnit v + | Interp_ast.V_lit (L_aux (L_unit) _) -> () + | Interp_ast.V_tuple [v] -> fromInterpValueUnit v | v -> failwith ("fromInterpValue unit: unexpected value. " ^ Interp.debug_print_value v) end @@ -44,8 +44,8 @@ end let toInterpValueInteger i = V_lit (L_aux (L_num i) Unknown) let rec fromInterpValueInteger v = match v with - | Interp.V_lit (L_aux (L_num i) _) -> i - | Interp.V_tuple [v] -> fromInterpValueInteger v + | Interp_ast.V_lit (L_aux (L_num i) _) -> i + | Interp_ast.V_tuple [v] -> fromInterpValueInteger v | v -> failwith ("fromInterpValue integer: unexpected value. " ^ Interp.debug_print_value v) end @@ -57,8 +57,8 @@ end let toInterpValueString s = V_lit (L_aux (L_string s) Unknown) let rec fromInterpValueString v = match v with - | Interp.V_lit (L_aux (L_string s) _) -> s - | Interp.V_tuple [v] -> fromInterpValueString v + | Interp_ast.V_lit (L_aux (L_string s) _) -> s + | Interp_ast.V_tuple [v] -> fromInterpValueString v | v -> failwith ("fromInterpValue integer: unexpected value. " ^ Interp.debug_print_value v) end @@ -69,17 +69,17 @@ end let toInterpValueBitU = function - | I -> Interp.V_lit (L_aux (L_one) Unknown) - | O -> Interp.V_lit (L_aux (L_zero) Unknown) - | Undef -> Interp.V_lit (L_aux (L_undef) Unknown) + | I -> Interp_ast.V_lit (L_aux (L_one) Unknown) + | O -> Interp_ast.V_lit (L_aux (L_zero) Unknown) + | Undef -> Interp_ast.V_lit (L_aux (L_undef) Unknown) end let rec fromInterpValueBitU v = match v with - | Interp.V_lit (L_aux (L_one) _) -> I - | Interp.V_lit (L_aux (L_zero) _) -> O - | Interp.V_lit (L_aux (L_undef) _) -> Undef - | Interp.V_lit (L_aux (L_true) _) -> I - | Interp.V_lit (L_aux (L_false) _) -> O - | Interp.V_tuple [v] -> fromInterpValueBitU v + | Interp_ast.V_lit (L_aux (L_one) _) -> B1 + | Interp_ast.V_lit (L_aux (L_zero) _) -> B0 + | Interp_ast.V_lit (L_aux (L_undef) _) -> BU + | Interp_ast.V_lit (L_aux (L_true) _) -> B1 + | Interp_ast.V_lit (L_aux (L_false) _) -> B0 + | Interp_ast.V_tuple [v] -> fromInterpValueBitU v | v -> failwith ("fromInterpValue bitU: unexpected value. " ^ Interp.debug_print_value v) end @@ -383,29 +383,31 @@ instance forall 'a. ToFromInterpValue 'a => (ToFromInterpValue (maybe 'a)) end -module SI = Interp -module SIA = Interp_ast - - let read_kindToInterpValue = function | Read_plain -> V_ctor (Id_aux (Id "Read_plain") Unknown) (T_id "read_kind") (C_Enum 0) (toInterpValue ()) - | Read_tag -> V_ctor (Id_aux (Id "Read_tag") Unknown) (T_id "read_kind") (C_Enum 1) (toInterpValue ()) - | Read_tag_reserve -> V_ctor (Id_aux (Id "Read_tag_reserve") Unknown) (T_id "read_kind") (C_Enum 1) (toInterpValue ()) | Read_reserve -> V_ctor (Id_aux (Id "Read_reserve") Unknown) (T_id "read_kind") (C_Enum 2) (toInterpValue ()) | Read_acquire -> V_ctor (Id_aux (Id "Read_acquire") Unknown) (T_id "read_kind") (C_Enum 3) (toInterpValue ()) | Read_exclusive -> V_ctor (Id_aux (Id "Read_exclusive") Unknown) (T_id "read_kind") (C_Enum 4) (toInterpValue ()) | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) end let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_plain") _) _ _ v -> Read_plain - | V_ctor (Id_aux (Id "Read_tag") _) _ _ v -> Read_tag - | V_ctor (Id_aux (Id "Read_tag_reserve") _) _ _ v -> Read_tag_reserve | V_ctor (Id_aux (Id "Read_reserve") _) _ _ v -> Read_reserve | V_ctor (Id_aux (Id "Read_acquire") _) _ _ v -> Read_acquire | V_ctor (Id_aux (Id "Read_exclusive") _) _ _ v -> Read_exclusive | V_ctor (Id_aux (Id "Read_exclusive_acquire") _) _ _ v -> Read_exclusive_acquire | V_ctor (Id_aux (Id "Read_stream") _) _ _ v -> Read_stream + | V_ctor (Id_aux (Id "Read_RISCV_acquire") _) _ _ v -> Read_RISCV_acquire + | V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") _) _ _ v -> Read_RISCV_strong_acquire + | V_ctor (Id_aux (Id "Read_RISCV_reserved") _) _ _ v -> Read_RISCV_reserved + | V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") _) _ _ v -> Read_RISCV_reserved_acquire + | V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") _) _ _ v -> Read_RISCV_reserved_strong_acquire | V_tuple [v] -> read_kindFromInterpValue v | v -> failwith ("fromInterpValue read_kind: unexpected value. " ^ Interp.debug_print_value v) @@ -418,21 +420,27 @@ end let write_kindToInterpValue = function | Write_plain -> V_ctor (Id_aux (Id "Write_plain") Unknown) (T_id "write_kind") (C_Enum 0) (toInterpValue ()) - | Write_tag -> V_ctor (Id_aux (Id "Write_tag") Unknown) (T_id "write_kind") (C_Enum 1) (toInterpValue ()) - | Write_tag_conditional -> V_ctor (Id_aux (Id "Write_tag_conditional") Unknown) (T_id "write_kind") (C_Enum 1) (toInterpValue ()) | Write_conditional -> V_ctor (Id_aux (Id "Write_conditional") Unknown) (T_id "write_kind") (C_Enum 2) (toInterpValue ()) | Write_release -> V_ctor (Id_aux (Id "Write_release") Unknown) (T_id "write_kind") (C_Enum 3) (toInterpValue ()) | Write_exclusive -> V_ctor (Id_aux (Id "Write_exclusive") Unknown) (T_id "write_kind") (C_Enum 4) (toInterpValue ()) | Write_exclusive_release -> V_ctor (Id_aux (Id "Write_exclusive_release") Unknown) (T_id "write_kind") (C_Enum 5) (toInterpValue ()) + | Write_RISCV_release -> V_ctor (Id_aux (Id "Write_RISCV_release") Unknown) (T_id "write_kind") (C_Enum 6) (toInterpValue ()) + | Write_RISCV_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_strong_release") Unknown) (T_id "write_kind") (C_Enum 7) (toInterpValue ()) + | Write_RISCV_conditional -> V_ctor (Id_aux (Id "Write_RISCV_conditional") Unknown) (T_id "write_kind") (C_Enum 8) (toInterpValue ()) + | Write_RISCV_conditional_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_release") Unknown) (T_id "write_kind") (C_Enum 9) (toInterpValue ()) + | Write_RISCV_conditional_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") Unknown) (T_id "write_kind") (C_Enum 10) (toInterpValue ()) end let rec write_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Write_plain") _) _ _ v -> Write_plain - | V_ctor (Id_aux (Id "Write_tag") _) _ _ v -> Write_tag - | V_ctor (Id_aux (Id "Write_tag_conditional") _) _ _ v -> Write_tag_conditional | V_ctor (Id_aux (Id "Write_conditional") _) _ _ v -> Write_conditional | V_ctor (Id_aux (Id "Write_release") _) _ _ v -> Write_release | V_ctor (Id_aux (Id "Write_exclusive") _) _ _ v -> Write_exclusive | V_ctor (Id_aux (Id "Write_exclusive_release") _) _ _ v -> Write_exclusive_release + | V_ctor (Id_aux (Id "Write_RISCV_release") _) _ _ v -> Write_RISCV_release + | V_ctor (Id_aux (Id "Write_RISCV_strong_release") _) _ _ v -> Write_RISCV_strong_release + | V_ctor (Id_aux (Id "Write_RISCV_conditional") _) _ _ v -> Write_RISCV_conditional + | V_ctor (Id_aux (Id "Write_RISCV_conditional_release") _) _ _ v -> Write_RISCV_conditional_release + | V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") _) _ _ v -> Write_RISCV_conditional_strong_release | V_tuple [v] -> write_kindFromInterpValue v | v -> failwith ("fromInterpValue write_kind: unexpected value " ^ Interp.debug_print_value v) @@ -455,7 +463,14 @@ let barrier_kindToInterpValue = function | Barrier_DSB_ST -> V_ctor (Id_aux (Id "Barrier_DSB_ST") Unknown) (T_id "barrier_kind") (C_Enum 8) (toInterpValue ()) | Barrier_DSB_LD -> V_ctor (Id_aux (Id "Barrier_DSB_LD") Unknown) (T_id "barrier_kind") (C_Enum 9) (toInterpValue ()) | Barrier_ISB -> V_ctor (Id_aux (Id "Barrier_ISB") Unknown) (T_id "barrier_kind") (C_Enum 10) (toInterpValue ()) - | Barrier_MIPS_SYNC -> V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") Unknown) (T_id "barrier_kind") (C_Enum 11) (toInterpValue ()) + | Barrier_TM_COMMIT -> V_ctor (Id_aux (Id "Barrier_TM_COMMIT") Unknown) (T_id "barrier_kind") (C_Enum 11) (toInterpValue ()) + | Barrier_MIPS_SYNC -> V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") Unknown) (T_id "barrier_kind") (C_Enum 12) (toInterpValue ()) + | Barrier_RISCV_rw_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") Unknown) (T_id "barrier_kind") (C_Enum 13) (toInterpValue ()) + | Barrier_RISCV_r_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") Unknown) (T_id "barrier_kind") (C_Enum 14) (toInterpValue ()) + | Barrier_RISCV_rw_w -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") Unknown) (T_id "barrier_kind") (C_Enum 15) (toInterpValue ()) + | Barrier_RISCV_w_w -> V_ctor (Id_aux (Id "Barrier_RISCV_w_w") Unknown) (T_id "barrier_kind") (C_Enum 16) (toInterpValue ()) + | Barrier_RISCV_i -> V_ctor (Id_aux (Id "Barrier_RISCV_i") Unknown) (T_id "barrier_kind") (C_Enum 17) (toInterpValue ()) + | Barrier_x86_MFENCE -> V_ctor (Id_aux (Id "Barrier_x86_MFENCE") Unknown) (T_id "barrier_kind") (C_Enum 18) (toInterpValue ()) end let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_Sync") _) _ _ v -> Barrier_Sync @@ -469,7 +484,14 @@ let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_DSB_ST") _) _ _ v -> Barrier_DSB_ST | V_ctor (Id_aux (Id "Barrier_DSB_LD") _) _ _ v -> Barrier_DSB_LD | V_ctor (Id_aux (Id "Barrier_ISB") _) _ _ v -> Barrier_ISB + | V_ctor (Id_aux (Id "Barrier_TM_COMMIT") _) _ _ v -> Barrier_TM_COMMIT | V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") _) _ _ v -> Barrier_MIPS_SYNC + | V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") _) _ _ v -> Barrier_RISCV_rw_rw + | V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") _) _ _ v -> Barrier_RISCV_r_rw + | V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") _) _ _ v -> Barrier_RISCV_rw_w + | V_ctor (Id_aux (Id "Barrier_RISCV_w_w") _) _ _ v -> Barrier_RISCV_w_w + | V_ctor (Id_aux (Id "Barrier_RISCV_i") _) _ _ v -> Barrier_RISCV_i + | V_ctor (Id_aux (Id "Barrier_x86_MFENCE") _) _ _ v -> Barrier_x86_MFENCE | V_tuple [v] -> barrier_kindFromInterpValue v | v -> failwith ("fromInterpValue barrier_kind: unexpected value. " ^ Interp.debug_print_value v) @@ -503,18 +525,18 @@ instance (ToFromInterpValue instruction_kind) end let regfpToInterpValue = function - | RFull v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RFull") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) - | RSlice v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RSlice") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) - | RSliceBit v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RSliceBit") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) - | RField v -> SI.V_ctor (SIA.Id_aux (SIA.Id "RField") SIA.Unknown) (SIA.T_id "regfp") SI.C_Union (toInterpValue v) + | RFull v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RFull") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) + | RSlice v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSlice") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) + | RSliceBit v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSliceBit") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) + | RField v -> Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RField") Interp_ast.Unknown) (Interp_ast.T_id "regfp") Interp_ast.C_Union (toInterpValue v) end let rec regfpFromInterpValue v = match v with - | SI.V_ctor (SIA.Id_aux (SIA.Id "RFull") _) _ _ v -> RFull (fromInterpValue v) - | SI.V_ctor (SIA.Id_aux (SIA.Id "RSlice") _) _ _ v -> RSlice (fromInterpValue v) - | SI.V_ctor (SIA.Id_aux (SIA.Id "RSliceBit") _) _ _ v -> RSliceBit (fromInterpValue v) - | SI.V_ctor (SIA.Id_aux (SIA.Id "RField") _) _ _ v -> RField (fromInterpValue v) - | SI.V_tuple [v] -> regfpFromInterpValue v + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RFull") _) _ _ v -> RFull (fromInterpValue v) + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSlice") _) _ _ v -> RSlice (fromInterpValue v) + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RSliceBit") _) _ _ v -> RSliceBit (fromInterpValue v) + | Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id "RField") _) _ _ v -> RField (fromInterpValue v) + | Interp_ast.V_tuple [v] -> regfpFromInterpValue v | v -> failwith ("fromInterpValue regfp: unexpected value. " ^ Interp.debug_print_value v) end diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 48ddd10e..e6169762 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -428,6 +428,8 @@ 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 diff --git a/src/pretty_print.mli b/src/pretty_print.mli index 9a002454..034db664 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -52,7 +52,7 @@ val pat_to_string : tannot pat -> string val pp_lem_defs : Format.formatter -> tannot defs -> unit val pp_defs_ocaml : out_channel -> tannot defs -> string -> string list -> unit -val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit +val pp_defs_lem : (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> (out_channel * string list) -> tannot defs -> string -> unit val pp_format_annot_ascii : tannot -> string diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 9758b2de..cf8fda59 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -50,7 +50,7 @@ open Pretty_print_common * PPrint-based sail-to-lem pprinter ****************************************************************************) -let print_to_from_interp_value = ref false +let print_to_from_interp_value = ref true let langlebar = string "<|" let ranglebar = string "|>" let anglebars = enclose langlebar ranglebar @@ -805,8 +805,8 @@ let rec doc_range_lem (BF_aux(r,_)) = match r with let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with | TD_abbrev(id,nm,typschm) -> - doc_op equals (concat [string "type"; space; doc_id_lem_type id]) - (doc_typschm_lem regtypes typschm) + (doc_op equals (concat [string "type"; space; doc_id_lem_type id]) + (doc_typschm_lem regtypes typschm),empty) | TD_record(id,nm,typq,fs,_) -> let f_pp (typ,fid) = let fname = if prefix_recordtype @@ -814,19 +814,19 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with else doc_id_lem_type fid in concat [fname;space;colon;space;doc_typ_lem regtypes typ; semi] in let fs_doc = group (separate_map (break 1) f_pp fs) in - doc_op equals + (doc_op equals (concat [string "type"; space; doc_id_lem_type id;]) - (doc_typquant_lem typq (anglebars (space ^^ align fs_doc ^^ space))) + (doc_typquant_lem typq (anglebars (space ^^ align fs_doc ^^ space))),empty) | TD_variant(id,nm,typq,ar,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> empty - | Id_aux ((Id "write_kind"),_) -> empty - | Id_aux ((Id "barrier_kind"),_) -> empty - | Id_aux ((Id "trans_kind"),_) -> empty - | Id_aux ((Id "instruction_kind"),_) -> empty - | Id_aux ((Id "regfp"),_) -> empty - | Id_aux ((Id "niafp"),_) -> empty - | Id_aux ((Id "diafp"),_) -> empty + | Id_aux ((Id "read_kind"),_) -> (empty,empty) + | Id_aux ((Id "write_kind"),_) -> (empty,empty) + | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) + | Id_aux ((Id "trans_kind"),_) -> (empty,empty) + | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) + | Id_aux ((Id "regfp"),_) -> (empty,empty) + | Id_aux ((Id "niafp"),_) -> (empty,empty) + | Id_aux ((Id "diafp"),_) -> (empty,empty) | _ -> let ar_doc = group (separate_map (break 1) (doc_type_union_lem regtypes) ar) in let typ_pp = @@ -835,9 +835,9 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with (concat [string "type"; space; doc_id_lem_type id;]) (doc_typquant_lem typq ar_doc) in let make_id pat id = - separate space [string "SIA.Id_aux"; - parens (string "SIA.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "SIA.Unknown"] in + separate space [string "Interp_ast.Id_aux"; + parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "Interp_ast.Unknown"] in let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let fromInterpValuePP = @@ -849,18 +849,18 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with match tu with | Tu_ty_id (ty,cid) -> (separate space) - [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid; parens (string "fromInterpValue v")] | Tu_id cid -> (separate space) - [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid]) ar) ^/^ - ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -879,43 +879,40 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with | Tu_ty_id (ty,cid) -> (separate space) [pipe;doc_id_lem_ctor cid;string "v";arrow; - string "SI.V_ctor"; + string "Interp_ast.V_ctor"; parens (make_id false cid); - parens (string "SIA.T_id " ^^ string_lit (doc_id id)); - string "SI.C_Union"; + parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); + string "Interp_ast.C_Union"; parens (string "toInterpValue v")] | Tu_id cid -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "SI.V_ctor"; + string "Interp_ast.V_ctor"; parens (make_id false cid); - parens (string "SIA.T_id " ^^ string_lit (doc_id id)); - string "SI.C_Union"; + parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); + string "Interp_ast.C_Union"; parens (string "toInterpValue ()")]) ar) ^/^ string "end") in let fromToInterpValuePP = + toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - typ_pp ^^ hardline ^^ hardline ^^ - if !print_to_from_interp_value then - toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ - fromToInterpValuePP ^^ hardline - else empty) + (typ_pp ^^ hardline,fromToInterpValuePP ^^ hardline)) | TD_enum(id,nm,enums,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> empty - | Id_aux ((Id "write_kind"),_) -> empty - | Id_aux ((Id "barrier_kind"),_) -> empty - | Id_aux ((Id "trans_kind"),_) -> empty - | Id_aux ((Id "instruction_kind"),_) -> empty - | Id_aux ((Id "regfp"),_) -> empty - | Id_aux ((Id "niafp"),_) -> empty - | Id_aux ((Id "diafp"),_) -> empty + | Id_aux ((Id "read_kind"),_) -> (empty,empty) + | Id_aux ((Id "write_kind"),_) -> (empty,empty) + | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) + | Id_aux ((Id "trans_kind"),_) -> (empty,empty) + | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) + | Id_aux ((Id "regfp"),_) -> (empty,empty) + | Id_aux ((Id "niafp"),_) -> (empty,empty) + | Id_aux ((Id "diafp"),_) -> (empty,empty) | _ -> let rec range i j = if i > j then [] else i :: (range (i+1) j) in let nats = range 0 in @@ -926,9 +923,9 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let make_id pat id = - separate space [string "SIA.Id_aux"; - parens (string "SIA.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "SIA.Unknown"] in + separate space [string "Interp_ast.Id_aux"; + parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "Interp_ast.Unknown"] in let fromInterpValuePP = (prefix 2 1) (separate space [string "let rec";fromInterpValueF;string "v";equals;string "match v with"]) @@ -936,7 +933,7 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with ((separate_map (break 1)) (fun (cid) -> (separate space) - [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow;doc_id_lem_ctor cid] ) enums @@ -944,7 +941,7 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with ( (align ((prefix 3 1) - (separate space [pipe;string ("SI.V_lit (SIA.L_aux (SIA.L_num n) _)");arrow]) + (separate space [pipe;string ("Interp_ast.V_lit (Interp_ast.L_aux (Interp_ast.L_num n) _)");arrow]) (separate space [string "match";parens(string "natFromInteger n");string "with"] ^/^ ( ((separate_map (break 1)) @@ -960,7 +957,7 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with ) ) ^/^ - ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -978,25 +975,23 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with (fun (cid,number) -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "SI.V_ctor"; + string "Interp_ast.V_ctor"; parens (make_id false cid); - parens (string "SIA.T_id " ^^ string_lit (doc_id id)); - parens (string ("SI.C_Enum " ^ string_of_int number)); + parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); + parens (string ("Interp_ast.C_Enum " ^ string_of_int number)); parens (string "toInterpValue ()")]) (List.combine enums (nats ((List.length enums) - 1)))) ^/^ string "end") in let fromToInterpValuePP = + toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - typ_pp ^^ hardline ^^ hardline ^^ - if !print_to_from_interp_value - then toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ - fromToInterpValuePP ^^ hardline - else empty) + (typ_pp ^^ hardline, + fromToInterpValuePP ^^ hardline)) | TD_register(id,n1,n2,rs) -> match n1,n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> @@ -1010,11 +1005,11 @@ let doc_typdef_lem regtypes (TD_aux(td,_)) = match td with let dir_b = i1 < i2 in let dir = string (if dir_b then "true" else "false") in let size = if dir_b then i2-i1 +1 else i1-i2 + 1 in - (doc_op equals) + ((doc_op equals) (concat [string "let";space;string "build_";doc_id_lem id;space;string "regname"]) (string "Register" ^^ space ^^ align (separate space [string "regname"; doc_int size; doc_int i1; dir; - break 0 ^^ brackets (align doc_rids)])) + break 0 ^^ brackets (align doc_rids)])),empty) (*^^ hardline ^^ separate_map hardline doc_rfield rs *) @@ -1147,26 +1142,29 @@ let doc_spec_lem regtypes (VS_aux (valspec,annot)) = let rec doc_def_lem regtypes def = match def with - | DEF_spec v_spec -> (doc_spec_lem regtypes v_spec,empty) - | DEF_type t_def -> (group (doc_typdef_lem regtypes t_def) ^/^ hardline,empty) - | DEF_reg_dec dec -> (group (doc_dec_lem dec),empty) + | DEF_spec v_spec -> ((doc_spec_lem regtypes v_spec,empty),empty) + | DEF_type t_def -> + let (typdefs,fromtodefs) = doc_typdef_lem regtypes t_def in + ((group typdefs ^/^ hardline,fromtodefs),empty) + | DEF_reg_dec dec -> ((group (doc_dec_lem dec),empty),empty) - | DEF_default df -> (empty,empty) - | DEF_fundef f_def -> (empty,group (doc_fundef_lem regtypes f_def) ^/^ hardline) - | DEF_val lbind -> (empty,group (doc_let_lem regtypes lbind) ^/^ hardline) + | DEF_default df -> ((empty,empty),empty) + | DEF_fundef f_def -> ((empty,empty),group (doc_fundef_lem regtypes f_def) ^/^ hardline) + | DEF_val lbind -> ((empty,empty),group (doc_let_lem regtypes lbind) ^/^ hardline) | DEF_scattered sdef -> failwith "doc_def_lem: shoulnd't have DEF_scattered at this point" - | DEF_kind _ -> (empty,empty) + | DEF_kind _ -> ((empty,empty),empty) - | DEF_comm (DC_comm s) -> (empty,comment (string s)) + | DEF_comm (DC_comm s) -> ((empty,empty),comment (string s)) | DEF_comm (DC_comm_struct d) -> - let (typdefs,vdefs) = doc_def_lem regtypes d in - (empty,comment (typdefs ^^ hardline ^^ vdefs)) + let ((typdefs,tofromdefs),vdefs) = doc_def_lem regtypes d in + ((empty,empty),comment (typdefs ^^ hardline ^^ tofromdefs ^^ hardline ^^ vdefs)) let doc_defs_lem regtypes (Defs defs) = let (typdefs,valdefs) = List.split (List.map (doc_def_lem regtypes) defs) in - (separate empty typdefs,separate empty valdefs) + let (typdefs,tofromdefs) = List.split typdefs in + (separate empty typdefs,separate empty tofromdefs, separate empty valdefs) let find_regtypes (Defs defs) = List.fold_left @@ -1180,38 +1178,33 @@ let find_regtypes (Defs defs) = let typ_to_t env = Type_check.typ_to_t env false false -let pp_defs_lem (types_file,types_modules) (prompt_file,prompt_modules) (state_file,state_modules) d top_line = +let pp_defs_lem + (types_file,types_modules) + (prompt_file,prompt_modules) + (state_file,state_modules) + (tofrom_file,tofrom_modules) + d top_line = + let pp_aux file modules defs = + (print file) + (concat + [string "(*" ^^ (string top_line) ^^ string "*)";hardline; + (separate_map hardline) + (fun lib -> separate space [string "open import";string lib]) modules;hardline; + defs]); + in + + let regtypes = find_regtypes d in - let (typdefs,valdefs) = doc_defs_lem regtypes d in - (print types_file) - (concat - [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) types_modules;hardline; - if !print_to_from_interp_value - then - concat - [(separate_map hardline) - (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"]; - string "open import Deep_shallow_convert"; - hardline; - hardline; - string "module SI = Interp"; hardline; - string "module SIA = Interp_ast"; hardline; - hardline] - else empty; - typdefs]); - (print prompt_file) - (concat - [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) prompt_modules;hardline; - hardline; - valdefs]); - (print state_file) + let (typdefs,tofromdefs,valdefs) = doc_defs_lem regtypes d in + + pp_aux types_file types_modules typdefs; + pp_aux prompt_file prompt_modules valdefs; + pp_aux state_file state_modules valdefs; + + (print tofrom_file) (concat [string "(*" ^^ (string top_line) ^^ string "*)";hardline; - (separate_map hardline) - (fun lib -> separate space [string "open import";string lib]) state_modules;hardline; - hardline; - valdefs]); + (separate_map hardline) (fun lib -> separate space [string "open import";string lib]) tofrom_modules;hardline; + (separate_map hardline) (fun lib -> separate space [string " import";string lib]) ["Interp";"Interp_ast"];hardline; + string "open import Deep_shallow_convert"; + hardline;tofromdefs]) diff --git a/src/process_file.ml b/src/process_file.ml index 273979cf..39a8bf58 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -172,18 +172,23 @@ let output1 libpath out_arg filename defs = | Lem_out None -> let generated_line = generated_line filename in let types_module = (f' ^ "_embed_types") in + let tofrom_module = (f' ^ "_toFromInterp") in let ((o,_, _) as ext_o) = open_output_with_check_unformatted (f' ^ "_embed_types.lem") in let ((o',_, _) as ext_o') = open_output_with_check_unformatted (f' ^ "_embed.lem") in let ((o'',_, _) as ext_o'') = open_output_with_check_unformatted (f' ^ "_embed_sequential.lem") in + let ((o''',_, _) as ext_o''') = + open_output_with_check_unformatted (f' ^ "_toFromInterp.lem") in (Pretty_print.pp_defs_lem (o,["Pervasives_extra";"Sail_impl_base";"Sail_values"]) (o',["Pervasives_extra";"Sail_impl_base";"Prompt";"Sail_values"; String.capitalize types_module]) (o'',["Pervasives_extra";"Sail_impl_base";"State";"Sail_values"; String.capitalize types_module]) + (o''',["Pervasives_extra";"Sail_impl_base";"Sail_values"; + String.capitalize types_module]) defs generated_line); close_output_with_check ext_o; close_output_with_check ext_o'; @@ -191,22 +196,28 @@ let output1 libpath out_arg filename defs = | Lem_out (Some lib) -> let generated_line = generated_line filename in let types_module = (f' ^ "_embed_types") in + let tofrom_module = (f' ^ "_toFromInterp") in let ((o,_, _) as ext_o) = open_output_with_check_unformatted (f' ^ "_embed_types.lem") in let ((o',_, _) as ext_o') = open_output_with_check_unformatted (f' ^ "_embed.lem") in let ((o'',_, _) as ext_o'') = open_output_with_check_unformatted (f' ^ "_embed_sequential.lem") in + let ((o''',_, _) as ext_o''') = + open_output_with_check_unformatted (f' ^ "_toFromInterp.lem") in (Pretty_print.pp_defs_lem (o,["Pervasives_extra";"Sail_impl_base";"Sail_values"]) (o',["Pervasives_extra";"Sail_impl_base";"Prompt"; "Sail_values";String.capitalize types_module;lib]) (o'',["Pervasives_extra";"Sail_impl_base";"State"; "Sail_values";String.capitalize types_module;lib ^ "_sequential"]) + (o''',["Pervasives_extra";"Sail_impl_base"; + "Sail_values";String.capitalize types_module;lib]) defs generated_line); close_output_with_check ext_o; close_output_with_check ext_o'; - close_output_with_check ext_o'' + close_output_with_check ext_o''; + close_output_with_check ext_o''' | Ocaml_out None -> let ((o,temp_file_name, _) as ext_o) = open_output_with_check_unformatted (f' ^ ".ml") in begin Pretty_print.pp_defs_ocaml o defs (generated_line filename) ["Big_int_Z";"Sail_values"]; -- cgit v1.2.3 From 3a4358d34cca39d61da4a21953be2a55f0a0a89e Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 15 Sep 2017 18:26:16 +0100 Subject: x86: implement regfp analysis function (no control flow yet) --- src/lem_interp/interp_inter_imp.lem | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 411ad3fc..6ee13d60 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -587,7 +587,8 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | "Barrier_DSB_ST" -> Barrier_DSB_ST | "Barrier_DSB_LD" -> Barrier_DSB_LD | "Barrier_ISB" -> Barrier_ISB - | "Barrier_MIPS_SYNC" -> Barrier_MIPS_SYNC + | "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) _) _ _ _) -> -- cgit v1.2.3 From c3b5af179dde8d0b2c272eb851ebdb59764468d0 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 19 Sep 2017 19:45:36 +0300 Subject: fix --- src/gen_lib/deep_shallow_convert.lem | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 4af6eb2f..42a65c49 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -69,9 +69,9 @@ end let toInterpValueBitU = function - | I -> Interp_ast.V_lit (L_aux (L_one) Unknown) - | O -> Interp_ast.V_lit (L_aux (L_zero) Unknown) - | Undef -> Interp_ast.V_lit (L_aux (L_undef) Unknown) + | B1 -> Interp_ast.V_lit (L_aux (L_one) Unknown) + | B0 -> Interp_ast.V_lit (L_aux (L_zero) Unknown) + | BU -> Interp_ast.V_lit (L_aux (L_undef) Unknown) end let rec fromInterpValueBitU v = match v with | Interp_ast.V_lit (L_aux (L_one) _) -> B1 @@ -391,10 +391,10 @@ let read_kindToInterpValue = function | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_RISCV_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) + | Read_RISCV_reserved -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) + | Read_RISCV_reserved_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_RISCV_reserved_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) end let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_plain") _) _ _ v -> Read_plain -- cgit v1.2.3 From a02e52919de565fc3fba82723b48200fbf034ff9 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Wed, 20 Sep 2017 15:38:14 +0100 Subject: add support for x86 lock prefix (also remove unused Read/Write_tag kind in etc/regfp.sail. --- src/lem_interp/sail_impl_base.lem | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index e6169762..e39c4421 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -441,6 +441,7 @@ type read_kind = | Read_RISCV_acquire | Read_RISCV_strong_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire | Read_RISCV_reserved_strong_acquire + | Read_X86_locked instance (Show read_kind) let show = function @@ -455,6 +456,7 @@ instance (Show read_kind) | 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 @@ -469,6 +471,7 @@ type write_kind = | Write_RISCV_release | Write_RISCV_strong_release | Write_RISCV_conditional | Write_RISCV_conditional_release | Write_RISCV_conditional_strong_release + | Write_X86_locked instance (Show write_kind) let show = function @@ -482,6 +485,7 @@ instance (Show write_kind) | 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 @@ -580,6 +584,7 @@ instance (EnumerationType read_kind) | Read_RISCV_reserved -> 8 | Read_RISCV_reserved_acquire -> 9 | Read_RISCV_reserved_strong_acquire -> 10 + | Read_X86_locked -> 11 end end @@ -595,6 +600,7 @@ instance (EnumerationType write_kind) | Write_RISCV_conditional -> 7 | Write_RISCV_conditional_release -> 8 | Write_RISCV_conditional_strong_release -> 9 + | Write_X86_locked -> 10 end end -- cgit v1.2.3 From 83adaea79d0ae53ff898985fdd359fbca7773de3 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 21 Sep 2017 09:51:41 +0100 Subject: added a comment to the x86 lock'd read and write --- src/lem_interp/sail_impl_base.lem | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index e39c4421..6957bb95 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -441,7 +441,8 @@ type read_kind = | Read_RISCV_acquire | Read_RISCV_strong_acquire | Read_RISCV_reserved | Read_RISCV_reserved_acquire | Read_RISCV_reserved_strong_acquire - | Read_X86_locked + (* x86 reads *) + | Read_X86_locked (* the read part of a lock'd instruction (rmw) *) instance (Show read_kind) let show = function @@ -471,7 +472,8 @@ type write_kind = | Write_RISCV_release | Write_RISCV_strong_release | Write_RISCV_conditional | Write_RISCV_conditional_release | Write_RISCV_conditional_strong_release - | Write_X86_locked + (* x86 writes *) + | Write_X86_locked (* the write part of a lock'd instruction (rmw) *) instance (Show write_kind) let show = function -- cgit v1.2.3 From 2148a88c9e9d16e07be1439ddc36ed69c31ee74c Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Thu, 21 Sep 2017 10:52:23 +0100 Subject: wib --- src/gen_lib/state.lem | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/gen_lib/state.lem b/src/gen_lib/state.lem index ac5cb869..88e29522 100644 --- a/src/gen_lib/state.lem +++ b/src/gen_lib/state.lem @@ -59,6 +59,7 @@ let is_exclusive = function | Sail_impl_base.Read_RISCV_reserved -> true | Sail_impl_base.Read_RISCV_reserved_acquire -> true | Sail_impl_base.Read_RISCV_reserved_strong_acquire -> true + | Sail_impl_base.Read_X86_locked -> true end -- cgit v1.2.3 From 72e597901e710f1549d387d9c1326b04be42e9d2 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Tue, 26 Sep 2017 12:23:46 +0100 Subject: fixes --- src/gen_lib/deep_shallow_convert.lem | 40 ++++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 18 deletions(-) (limited to 'src') diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 42a65c49..86365b78 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -385,16 +385,17 @@ end let read_kindToInterpValue = function | Read_plain -> V_ctor (Id_aux (Id "Read_plain") Unknown) (T_id "read_kind") (C_Enum 0) (toInterpValue ()) - | Read_reserve -> V_ctor (Id_aux (Id "Read_reserve") Unknown) (T_id "read_kind") (C_Enum 2) (toInterpValue ()) - | Read_acquire -> V_ctor (Id_aux (Id "Read_acquire") Unknown) (T_id "read_kind") (C_Enum 3) (toInterpValue ()) - | Read_exclusive -> V_ctor (Id_aux (Id "Read_exclusive") Unknown) (T_id "read_kind") (C_Enum 4) (toInterpValue ()) - | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) - | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) - | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) - | Read_RISCV_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) - | Read_RISCV_reserved -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) - | Read_RISCV_reserved_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_reserve -> V_ctor (Id_aux (Id "Read_reserve") Unknown) (T_id "read_kind") (C_Enum 1) (toInterpValue ()) + | Read_acquire -> V_ctor (Id_aux (Id "Read_acquire") Unknown) (T_id "read_kind") (C_Enum 2) (toInterpValue ()) + | Read_exclusive -> V_ctor (Id_aux (Id "Read_exclusive") Unknown) (T_id "read_kind") (C_Enum 3) (toInterpValue ()) + | Read_exclusive_acquire -> V_ctor (Id_aux (Id "Read_exclusive_acquire") Unknown) (T_id "read_kind") (C_Enum 4) (toInterpValue ()) + | Read_stream -> V_ctor (Id_aux (Id "Read_stream") Unknown) (T_id "read_kind") (C_Enum 5) (toInterpValue ()) + | Read_RISCV_acquire -> V_ctor (Id_aux (Id "Read_RISCV_acquire") Unknown) (T_id "read_kind") (C_Enum 6) (toInterpValue ()) + | Read_RISCV_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 7) (toInterpValue ()) + | Read_RISCV_reserved -> V_ctor (Id_aux (Id "Read_RISCV_reserved") Unknown) (T_id "read_kind") (C_Enum 8) (toInterpValue ()) + | Read_RISCV_reserved_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") Unknown) (T_id "read_kind") (C_Enum 9) (toInterpValue ()) | Read_RISCV_reserved_strong_acquire -> V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") Unknown) (T_id "read_kind") (C_Enum 10) (toInterpValue ()) + | Read_X86_locked -> V_ctor (Id_aux (Id "Read_X86_locked") Unknown) (T_id "read_kind") (C_Enum 11) (toInterpValue ()) end let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_plain") _) _ _ v -> Read_plain @@ -408,6 +409,7 @@ let rec read_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Read_RISCV_reserved") _) _ _ v -> Read_RISCV_reserved | V_ctor (Id_aux (Id "Read_RISCV_reserved_acquire") _) _ _ v -> Read_RISCV_reserved_acquire | V_ctor (Id_aux (Id "Read_RISCV_reserved_strong_acquire") _) _ _ v -> Read_RISCV_reserved_strong_acquire + | V_ctor (Id_aux (Id "Read_X86_locked") _) _ _ v -> Read_X86_locked | V_tuple [v] -> read_kindFromInterpValue v | v -> failwith ("fromInterpValue read_kind: unexpected value. " ^ Interp.debug_print_value v) @@ -420,15 +422,16 @@ end let write_kindToInterpValue = function | Write_plain -> V_ctor (Id_aux (Id "Write_plain") Unknown) (T_id "write_kind") (C_Enum 0) (toInterpValue ()) - | Write_conditional -> V_ctor (Id_aux (Id "Write_conditional") Unknown) (T_id "write_kind") (C_Enum 2) (toInterpValue ()) - | Write_release -> V_ctor (Id_aux (Id "Write_release") Unknown) (T_id "write_kind") (C_Enum 3) (toInterpValue ()) - | Write_exclusive -> V_ctor (Id_aux (Id "Write_exclusive") Unknown) (T_id "write_kind") (C_Enum 4) (toInterpValue ()) - | Write_exclusive_release -> V_ctor (Id_aux (Id "Write_exclusive_release") Unknown) (T_id "write_kind") (C_Enum 5) (toInterpValue ()) - | Write_RISCV_release -> V_ctor (Id_aux (Id "Write_RISCV_release") Unknown) (T_id "write_kind") (C_Enum 6) (toInterpValue ()) - | Write_RISCV_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_strong_release") Unknown) (T_id "write_kind") (C_Enum 7) (toInterpValue ()) - | Write_RISCV_conditional -> V_ctor (Id_aux (Id "Write_RISCV_conditional") Unknown) (T_id "write_kind") (C_Enum 8) (toInterpValue ()) - | Write_RISCV_conditional_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_release") Unknown) (T_id "write_kind") (C_Enum 9) (toInterpValue ()) - | Write_RISCV_conditional_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") Unknown) (T_id "write_kind") (C_Enum 10) (toInterpValue ()) + | Write_conditional -> V_ctor (Id_aux (Id "Write_conditional") Unknown) (T_id "write_kind") (C_Enum 1) (toInterpValue ()) + | Write_release -> V_ctor (Id_aux (Id "Write_release") Unknown) (T_id "write_kind") (C_Enum 2) (toInterpValue ()) + | Write_exclusive -> V_ctor (Id_aux (Id "Write_exclusive") Unknown) (T_id "write_kind") (C_Enum 3) (toInterpValue ()) + | Write_exclusive_release -> V_ctor (Id_aux (Id "Write_exclusive_release") Unknown) (T_id "write_kind") (C_Enum 4) (toInterpValue ()) + | Write_RISCV_release -> V_ctor (Id_aux (Id "Write_RISCV_release") Unknown) (T_id "write_kind") (C_Enum 5) (toInterpValue ()) + | Write_RISCV_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_strong_release") Unknown) (T_id "write_kind") (C_Enum 6) (toInterpValue ()) + | Write_RISCV_conditional -> V_ctor (Id_aux (Id "Write_RISCV_conditional") Unknown) (T_id "write_kind") (C_Enum 7) (toInterpValue ()) + | Write_RISCV_conditional_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_release") Unknown) (T_id "write_kind") (C_Enum 8) (toInterpValue ()) + | Write_RISCV_conditional_strong_release -> V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") Unknown) (T_id "write_kind") (C_Enum 9) (toInterpValue ()) + | Write_X86_locked -> V_ctor (Id_aux (Id "Write_X86_locked") Unknown) (T_id "write_kind") (C_Enum 10) (toInterpValue ()) end let rec write_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Write_plain") _) _ _ v -> Write_plain @@ -441,6 +444,7 @@ let rec write_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Write_RISCV_conditional") _) _ _ v -> Write_RISCV_conditional | V_ctor (Id_aux (Id "Write_RISCV_conditional_release") _) _ _ v -> Write_RISCV_conditional_release | V_ctor (Id_aux (Id "Write_RISCV_conditional_strong_release") _) _ _ v -> Write_RISCV_conditional_strong_release + | V_ctor (Id_aux (Id "Write_X86_locked") _) _ _ v -> Write_X86_locked | V_tuple [v] -> write_kindFromInterpValue v | v -> failwith ("fromInterpValue write_kind: unexpected value " ^ Interp.debug_print_value v) -- cgit v1.2.3 From efa98fb796fdab5486193f792adf999826fde7b4 Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 29 Sep 2017 17:02:38 +0100 Subject: fix deep_shallow_convert, stop using interp_interface.instruction for most things, SF and CP bugfixing --- src/gen_lib/deep_shallow_convert.lem | 29 ++++++++++++++++++-- src/lem_interp/interp.lem | 4 +-- src/lem_interp/interp_inter_imp.lem | 53 ++++++++++++++++++------------------ src/lem_interp/interp_interface.lem | 10 +++++-- src/lem_interp/sail_impl_base.lem | 2 -- 5 files changed, 62 insertions(+), 36 deletions(-) (limited to 'src') diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 86365b78..5a0dd99e 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -15,10 +15,10 @@ let toInterValueBool = function | false -> Interp_ast.V_lit (L_aux (L_zero) Unknown) end let rec fromInterpValueBool v = match v with - | Interp_ast.V_lit (L_aux (L_true) _) -> true - | Interp_ast.V_lit (L_aux (L_false) _) -> false | Interp_ast.V_lit (L_aux (L_one) _) -> true + | Interp_ast.V_lit (L_aux (L_true) _) -> true | Interp_ast.V_lit (L_aux (L_zero) _) -> false + | Interp_ast.V_lit (L_aux (L_false) _) -> false | Interp_ast.V_tuple [v] -> fromInterpValueBool v | v -> failwith ("fromInterpValue bool: unexpected value. " ^ Interp.debug_print_value v) @@ -78,7 +78,7 @@ let rec fromInterpValueBitU v = match v with | Interp_ast.V_lit (L_aux (L_zero) _) -> B0 | Interp_ast.V_lit (L_aux (L_undef) _) -> BU | Interp_ast.V_lit (L_aux (L_true) _) -> B1 - | Interp_ast.V_lit (L_aux (L_false) _) -> B0 + | Interp_ast.V_lit (L_aux (L_false) _) -> B0 | Interp_ast.V_tuple [v] -> fromInterpValueBitU v | v -> failwith ("fromInterpValue bitU: unexpected value. " ^ Interp.debug_print_value v) @@ -506,18 +506,41 @@ instance (ToFromInterpValue barrier_kind) end +let trans_kindToInterpValue = function + | Transaction_start -> V_ctor (Id_aux (Id "Transaction_start") Unknown) (T_id "trans_kind") (C_Enum 0) (toInterpValue ()) + | Transaction_commit -> V_ctor (Id_aux (Id "Transaction_commit") Unknown) (T_id "trans_kind") (C_Enum 1) (toInterpValue ()) + | Transaction_abort -> V_ctor (Id_aux (Id "Transaction_abort") Unknown) (T_id "trans_kind") (C_Enum 2) (toInterpValue ()) + end +let rec trans_kindFromInterpValue v = match v with + | V_ctor (Id_aux (Id "Transaction_start") _) _ _ v -> Transaction_start + | V_ctor (Id_aux (Id "Transaction_commit") _) _ _ v -> Transaction_commit + | V_ctor (Id_aux (Id "Transaction_abort") _) _ _ v -> Transaction_abort + | V_tuple [v] -> trans_kindFromInterpValue v + | v -> failwith ("fromInterpValue trans_kind: unexpected value. " ^ + Interp.debug_print_value v) + end +instance (ToFromInterpValue trans_kind) + let toInterpValue = trans_kindToInterpValue + let fromInterpValue = trans_kindFromInterpValue +end + + let instruction_kindToInterpValue = function | IK_barrier v -> V_ctor (Id_aux (Id "IK_barrier") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_mem_read v -> V_ctor (Id_aux (Id "IK_mem_read") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_mem_write v -> V_ctor (Id_aux (Id "IK_mem_write") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) + | IK_mem_rmw v -> V_ctor (Id_aux (Id "IK_mem_rmw") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_cond_branch -> V_ctor (Id_aux (Id "IK_cond_branch") Unknown) (T_id "instruction_kind") C_Union (toInterpValue ()) + | IK_trans v -> V_ctor (Id_aux (Id "IK_trans") Unknown) (T_id "instruction_kind") C_Union (toInterpValue v) | IK_simple -> V_ctor (Id_aux (Id "IK_simple") Unknown) (T_id "instruction_kind") C_Union (toInterpValue ()) end let rec instruction_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "IK_barrier") _) _ _ v -> IK_barrier (fromInterpValue v) | V_ctor (Id_aux (Id "IK_mem_read") _) _ _ v -> IK_mem_read (fromInterpValue v) | V_ctor (Id_aux (Id "IK_mem_write") _) _ _ v -> IK_mem_write (fromInterpValue v) + | V_ctor (Id_aux (Id "IK_mem_rmw") _) _ _ v -> IK_mem_rmw (fromInterpValue v) | V_ctor (Id_aux (Id "IK_cond_branch") _) _ _ v -> IK_cond_branch + | V_ctor (Id_aux (Id "IK_trans") _) _ _ v -> IK_trans (fromInterpValue v) | V_ctor (Id_aux (Id "IK_simple") _) _ _ v -> IK_simple | V_tuple [v] -> instruction_kindFromInterpValue v | v -> failwith ("fromInterpValue instruction_kind: unexpected value. " ^ diff --git a/src/lem_interp/interp.lem b/src/lem_interp/interp.lem index 58874fa6..f00458b7 100644 --- a/src/lem_interp/interp.lem +++ b/src/lem_interp/interp.lem @@ -1424,8 +1424,8 @@ let rec match_pattern t_level (P_aux p (_, annot)) value_whole = | V_ctor (Id_aux cid _) t ckind v -> if id = cid then (match (pats,detaint v) with - | ([],(V_lit (L_aux L_unit _))) -> (true,true,eenv) - | ([P_aux (P_lit (L_aux L_unit _)) _],(V_lit (L_aux L_unit _))) -> (true,true,eenv) + | ([],(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) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 6ee13d60..52acae1e 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -469,7 +469,7 @@ let translate_address top_level end_flag thunk_name registers address = 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 ("",[]) internal_direction + interp_to_value_helper debug (Just (Opcode bytes)) Ivh_translate val_str (V_list []) internal_direction registers [] false (fun _ -> Interp.resume int_mode @@ -504,17 +504,16 @@ let intern_instruction direction (name,parms) = Interp_ast.V_ctor (Interp.id_of_string name) (T_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 = +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 intern_val = intern_instruction direction instruction in - let val_str = Interp.string_of_value intern_val in - let (arg,_) = Interp.to_exp int_mode Interp.eenv intern_val 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 ("",[]) internal_direction + interp_to_value_helper debug Nothing Ivh_analysis val_str (V_list []) internal_direction registers [] false (fun _ -> Interp.resume int_mode @@ -680,7 +679,7 @@ let decode_to_instruction top_level registers value : instruction_or_decode_erro 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 ("",[]) internal_direction registers [] false + interp_to_value_helper debug (Just value) Ivh_decode val_str (V_list []) internal_direction registers [] false (fun _ -> Interp.resume mode (Interp.Thunk_frame @@ -688,9 +687,9 @@ let decode_to_instruction top_level registers value : instruction_or_decode_erro 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_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_external internal_direction + interp_to_value_helper debug (Just value) Ivh_unsupported val_str instr (*instr_external*) internal_direction registers [] false (fun _ -> Interp.resume mode @@ -699,7 +698,7 @@ let decode_to_instruction top_level registers value : instruction_or_decode_erro (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_external instr + | 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 @@ -713,9 +712,9 @@ 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 instrv -> + | IDE_instr instr -> let mode = make_interpreter_mode true false in - let (arg,_) = Interp.to_exp mode Interp.eenv instrv 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)) @@ -750,11 +749,11 @@ let instr_external_to_interp_value top_level instr = Interp_ast.V_ctor (Interp_ast.Id_aux (Interp_ast.Id name) Interp_ast.Unknown) (T_id "ast") Interp_ast.C_Union parmsV -val instruction_to_istate : context -> instruction -> instruction_state -let instruction_to_istate (top_level:context) (((name, parms) as instr):instruction) : instruction_state = +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_external_to_interp_value top_level instr)) 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]) @@ -1092,7 +1091,7 @@ and state_to_outcome_s pp_instruction_state mode 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 -> instruction -> Sail_impl_base.outcome_s unit +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 @@ -1222,14 +1221,15 @@ let nia_address_of_event nia_reg (event: event) : maybe (maybe address) = | _ -> Nothing end -let nias_of_instruction +let nias_of_instruction + top_level thread_ism (nia_address: list (maybe address)) (* Nothing for unknown/undef*) (regs_in: list reg_name) - (instruction: instruction) + (instruction: Interp_ast.value) : list nia = - let (instruction_name, instruction_fields) = instruction in + let (instruction_name, instruction_fields) = interp_value_to_instr_external top_level instruction in let unknown_nia_address = List.elem Nothing nia_address in @@ -1390,7 +1390,9 @@ let nias_of_instruction | (s1, s2) -> failwith ("unexpected (thread_ism, instruction_name): (" ^ s1 ^ ", " ^ s2 ^ ")") end + let interp_instruction_analysis + top_level (interp_exhaustive : ((list (reg_name * register_value)) -> list event)) instruction nia_reg ism environment = @@ -1403,7 +1405,7 @@ let interp_instruction_analysis let nia_address = List.mapMaybe (nia_address_of_event nia_reg) es in - let nias = nias_of_instruction ism nia_address regs_in instruction in + let nias = nias_of_instruction top_level ism nia_address regs_in instruction in let dia = DIA_none in (* FIX THIS! *) @@ -1478,29 +1480,28 @@ val print_and_fail_of_inequal : forall 'a. Show 'a => (instruction -> string) -> (string * 'a) -> (string * 'a) -> unit let print_and_fail_if_inequal - (print_endline,pp_instruction,instruction) + (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 " ^ pp_instruction instruction) + failwith (name1^" and "^ name2^" inequal for instruction: \n" ^ Interp.string_of_value instruction) let interp_compare_analyses print_endline - pp_instruction (non_pseudo_registers : set reg_name -> set reg_name) context endianness interp_exhaustive - instruction + (instruction : Interp_ast.value) nia_reg ism environment analysis_function reg_info = let (regs_in1,regs_out1,regs_feeding_address1,nias1,dia1,inst_kind1) = - interp_instruction_analysis interp_exhaustive instruction nia_reg ism + interp_instruction_analysis context interp_exhaustive instruction nia_reg ism environment in let (regs_in1S,regs_out1S,regs_feeding_address1S,nias1S) = (Set.fromList regs_in1, @@ -1525,7 +1526,7 @@ let interp_compare_analyses non_pseudo_registers regs_out2S, non_pseudo_registers regs_feeding_address2S) in - let aux = (print_endline,pp_instruction,instruction) 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 diff --git a/src/lem_interp/interp_interface.lem b/src/lem_interp/interp_interface.lem index dcc9f537..07d9e2b3 100644 --- a/src/lem_interp/interp_interface.lem +++ b/src/lem_interp/interp_interface.lem @@ -104,6 +104,10 @@ end 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 @@ -117,7 +121,7 @@ let inline ~{coq} instructionInequal = unsafe_structural_inequality type v_kind = Bitv | Bytev type decode_error = - | Unsupported_instruction_error of instruction + | Unsupported_instruction_error of Interp_ast.value | Not_an_instruction_error of opcode | Internal_error of string @@ -264,12 +268,12 @@ val initial_instruction_state : context -> string -> list register_value -> inst (* string is a function name, list of value are the parameters to that function *) type instruction_or_decode_error = - | IDE_instr of instruction * Interp_ast.value + | 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 instruction * instruction_state + | Instr of Interp_ast.value * instruction_state | Decode_error of decode_error diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 6957bb95..4f07f574 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -106,8 +106,6 @@ type register_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 -- cgit v1.2.3 From 9f58a1bbaadd0a679413a8cb424acfb6255f8eca Mon Sep 17 00:00:00 2001 From: Christopher Pulte Date: Fri, 29 Sep 2017 17:55:48 +0100 Subject: fix those build errors --- src/lem_interp/run_with_elf.ml | 10 +++++++--- src/lem_interp/run_with_elf_cheri.ml | 6 ++++-- src/lem_interp/run_with_elf_cheri128.ml | 6 ++++-- 3 files changed, 15 insertions(+), 7 deletions(-) (limited to 'src') diff --git a/src/lem_interp/run_with_elf.ml b/src/lem_interp/run_with_elf.ml index 2a1783db..98b98a03 100644 --- a/src/lem_interp/run_with_elf.ml +++ b/src/lem_interp/run_with_elf.ml @@ -1198,12 +1198,16 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let opcode = Opcode (get_opcode pc) in let (instruction,istate) = match Interp_inter_imp.decode_to_istate context None opcode with | Instr(instruction,istate) -> - interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); + let instruction = interp_value_to_instr_external context instruction in + interactf "\n**** Running: %s ****\n" + (Printing_functions.instruction_to_string instruction); (instruction,istate) | Decode_error d -> (match d with - | Interp_interface.Unsupported_instruction_error instr -> - errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Unsupported_instruction_error instruction -> + let instruction = interp_value_to_instr_external context instruction in + errorf "\n**** Encountered unsupported instruction %s ****\n" + (Printing_functions.instruction_to_string instruction) | Interp_interface.Not_an_instruction_error op -> (match op with | Opcode bytes -> diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index e773bf5b..b879f702 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -1290,12 +1290,14 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let opcode = Opcode (get_opcode pc) in let (instruction,istate) = match Interp_inter_imp.decode_to_istate context None opcode with | Instr(instruction,istate) -> + let instruction = interp_value_to_instr_external context instruction in interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); (instruction,istate) | Decode_error d -> (match d with - | Interp_interface.Unsupported_instruction_error instr -> - errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Unsupported_instruction_error instruction -> + let instruction = interp_value_to_instr_external context instruction in + errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instruction) | Interp_interface.Not_an_instruction_error op -> (match op with | Opcode bytes -> diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index cd2e7312..3ad507bc 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -1290,12 +1290,14 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let opcode = Opcode (get_opcode pc) in let (instruction,istate) = match Interp_inter_imp.decode_to_istate context None opcode with | Instr(instruction,istate) -> + let instruction = interp_value_to_instr_external context instruction in interactf "\n**** Running: %s ****\n" (Printing_functions.instruction_to_string instruction); (instruction,istate) | Decode_error d -> (match d with - | Interp_interface.Unsupported_instruction_error instr -> - errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instr) + | Interp_interface.Unsupported_instruction_error instruction -> + let instruction = interp_value_to_instr_external context instruction in + errorf "\n**** Encountered unsupported instruction %s ****\n" (Printing_functions.instruction_to_string instruction) | Interp_interface.Not_an_instruction_error op -> (match op with | Opcode bytes -> -- cgit v1.2.3 From dd733219d795bd59516c54717e798ced9c378d33 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Fri, 6 Oct 2017 14:47:23 +0100 Subject: move nias_of_instruction into RMEM so that it can use shallow embedding ast and not obsolete interp_interface one. --- src/lem_interp/interp_inter_imp.lem | 180 ++---------------------------------- 1 file changed, 7 insertions(+), 173 deletions(-) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 52acae1e..c0d2ea4a 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -1221,180 +1221,13 @@ let nia_address_of_event nia_reg (event: event) : maybe (maybe address) = | _ -> Nothing end -let nias_of_instruction - top_level - thread_ism - (nia_address: list (maybe address)) (* Nothing for unknown/undef*) - (regs_in: list reg_name) - (instruction: Interp_ast.value) - : list nia - = - let (instruction_name, instruction_fields) = interp_value_to_instr_external top_level instruction in - - let unknown_nia_address = List.elem Nothing nia_address in - - let nias = [NIA_concrete_address addr | forall (addr MEM (List.mapMaybe id nia_address)) | true] in - - (* it's a fact of the Power2.06B instruction pseudocode that in the B and Bc - cases there should be no Unknown values in nia_values, while in the Bclr - and Bcctr cases nia_values will just be Unknown and the semantics should - match the comments in the machineDefTypes definition of nia *) - (* All our other analysis is on the pseudocode directly, which is arguably - pleasingly robust. We could replace the nias pattern match on - instruction_name with something in that style if the exhaustive interpreter - announced register dependencies to register writes (easy) and if it could - check the form of the register writes to LR and CTR matches the - machineDefTypes nia definition *) - match (thread_ism, instruction_name) with - | ("PPCGEN_ism", "B") -> - let () = ensure (not unknown_nia_address) - "unexpected unknown/undefined address in nia_values 1" in - nias - | ("PPCGEN_ism", "Bc") -> - let () = ensure (not unknown_nia_address) - "unexpected unknown/undefined address in nia_values 2" in - NIA_successor :: nias - | ("PPCGEN_ism", "Bclr") -> [ NIA_successor; NIA_LR ] - | ("PPCGEN_ism", "Bcctr") -> [ NIA_successor; NIA_CTR ] - | ("PPCGEN_ism", "Sc") -> - let () = ensure (not unknown_nia_address) - "unexpected unknown/undefined address in nia_values 3" in - match instruction_fields with - | [(_, _, lev)] -> - (* LEV field is 7 bits long, pad it with false at beginning *) - if lev = [Bitc_zero;Bitc_one;Bitc_one;Bitc_one;Bitc_one;Bitc_one;Bitc_one] - (* (Interp_inter_imp.integer_of_byte_list (Interp_inter_imp.to_bytes (false :: bl))) = 63 *) - then [] - else [NIA_successor] - | _ -> [ NIA_successor ] - end - | ("PPCGEN_ism", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"PPCGEN_ism\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - (* AARch64 label branch (i.e. address must be known) although - these instructions take the address as an offset from PC, in here - we see the absolute address as it was extracted from the micro ops - just before write to PC *) - | ("AArch64HandSail", "BranchImmediate") -> nias - | ("AArch64HandSail", "BranchConditional") -> NIA_successor :: nias - | ("AArch64HandSail", "CompareAndBranch") -> NIA_successor :: nias - | ("AArch64HandSail", "TestBitAndBranch") -> NIA_successor :: nias - - (* AArch64 calculated address branch *) - | ("AArch64HandSail", "BranchRegister") -> - (* do some parsing of the ast fields to figure out which register holds - the branching address i.e. find n in "BR ". The ast constructor - from armV8.sail: (reg_index,BranchType) BranchRegister; *) - let n_integer = - match instruction_fields with - | [(_, _, n); _] -> integer_of_bit_list n - | _ -> fail - end - in - let () = ensure (0 <= n_integer && n_integer <= 31) - "expected register number from 0 to 31" - in - if n_integer = 31 then - nias (* BR XZR *) - else - (* look for Xn (which we actually call Rn) in regs_in *) - let n_reg = "R" ^ (String_extra.stringFromInteger n_integer) in - [NIA_register r | forall (r MEM regs_in) - | match r with - | (Reg name _ _ _) -> name = n_reg - | _ -> false - end] - | ("AArch64HandSail", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"AArch64HandSail\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - (** hacky cut-and-paste for AArch64Gen, duplicating code just to see if this suffices *) - - | ("AArch64GenSail", "BranchImmediate") -> nias - | ("AArch64GenSail", "BranchConditional") -> NIA_successor :: nias - | ("AArch64GenSail", "CompareAndBranch") -> NIA_successor :: nias - | ("AArch64GenSail", "TestBitAndBranch") -> NIA_successor :: nias - - (* AArch64 calculated address branch *) - | ("AArch64GenSail", "branch_unconditional_register") -> - (* do some parsing of the ast fields to figure out which register holds - the branching address i.e. find n in "BR ". The ast constructor - from armV8.sail: (reg_index,BranchType) BranchRegister; *) - let n_integer = - match instruction_fields with - | [(_, _, n); _] -> integer_of_bit_list n - | _ -> fail - end - in - let () = ensure (0 <= n_integer && n_integer <= 31) - "expected register number from 0 to 31" - in - if n_integer = 31 then - nias (* BR XZR *) - else - (* look for Xn (which we actually call Rn) in regs_in *) - let n_reg = "R" ^ (String_extra.stringFromInteger n_integer) in - [NIA_register r | forall (r MEM regs_in) - | match r with - | (Reg name _ _ _) -> name = n_reg - | _ -> false - end] - | ("AArch64GenSail", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"AArch64GenSail\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - (** end of hacky *) - - | ("AArch64LitmusSail", "CtrlDep") -> NIA_successor :: nias - | ("AArch64LitmusSail", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"AArch64LitmusSail\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - - | ("MIPS_ism", "B") -> fail - | ("MIPS_ism", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"MIPS_ism\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - | ("RISCV_ism", "JAL") -> nias - | ("RISCV_ism", "JALR") -> - let rs1_integer = - match instruction_fields with - | [_; (_, _, rs1); _] -> integer_of_bit_list rs1 - | _ -> fail - end - in - let () = ensure (0 <= rs1_integer && rs1_integer <= 31) - "expected register number from 0 to 31" - in - if rs1_integer = 0 then nias - else - let rs1_reg = "x" ^ (String_extra.stringFromInteger rs1_integer) in - [NIA_register r | forall (r MEM regs_in) - | match r with - | (Reg name _ _ _) -> name = rs1_reg - | _ -> false - end] - | ("RISCV_ism", "BTYPE") -> NIA_successor :: nias - | ("RISCV_ism", s) -> - let () = ensure (not unknown_nia_address) - ("unexpected unknown/undefined address in nia_values 4 (\"RISCV_ism\", \"" ^ s ^ "\")") in - [ NIA_successor ] - - | (s1, s2) -> failwith ("unexpected (thread_ism, instruction_name): (" ^ s1 ^ ", " ^ s2 ^ ")") - end - - let interp_instruction_analysis top_level (interp_exhaustive : ((list (reg_name * register_value)) -> list event)) - instruction nia_reg ism environment = + instruction + nia_reg + (nias_function : (list (maybe address) -> list reg_name -> list nia)) + ism environment = let es = interp_exhaustive environment in @@ -1405,7 +1238,7 @@ let interp_instruction_analysis let nia_address = List.mapMaybe (nia_address_of_event nia_reg) es in - let nias = nias_of_instruction top_level ism nia_address regs_in instruction in + let nias = nias_function nia_address regs_in in let dia = DIA_none in (* FIX THIS! *) @@ -1496,12 +1329,13 @@ let interp_compare_analyses interp_exhaustive (instruction : Interp_ast.value) nia_reg + (nias_function : (list (maybe address) -> list reg_name -> 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 ism + 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, -- cgit v1.2.3 From 97b808681f951a962cdb3c087d79aee5556a7089 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 9 Oct 2017 16:14:08 +0100 Subject: add translation of IK_mem_rmw interp_inter_imp. TODO: could we get rid of this and use shallow embedding conversion? --- src/lem_interp/interp_inter_imp.lem | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index c0d2ea4a..1c993ba0 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -571,6 +571,21 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | Interp_ast.V_ctor (Id_aux (Id "NIAFP_register") _) _ _ reg -> NIA_register (reg_to_reg_name reg) | _ -> 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 + | 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 + | 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) _) _ _ _) -> @@ -591,23 +606,14 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis end) | Interp_ast.V_ctor (Id_aux (Id "IK_mem_read") _) _ _ (Interp_ast.V_ctor (Id_aux (Id r) _) _ _ _) -> - IK_mem_read (match r with - | "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 - end) + 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 (match w with - | "Write_plain" -> Write_plain - | "Write_conditional" -> Write_conditional - | "Write_release" -> Write_release - | "Write_exclusive" -> Write_exclusive - | "Write_exclusive_release" -> Write_exclusive_release - end) + 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_cond_branch") _) _ _ _ -> IK_cond_branch | Interp_ast.V_ctor (Id_aux (Id "IK_simple") _) _ _ _ -> -- cgit v1.2.3 From 93dfd61038583eac852e5e3ea66c46817a610bbe Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Mon, 9 Oct 2017 16:38:03 +0100 Subject: add translations for missing read/write kinds. --- src/lem_interp/interp_inter_imp.lem | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 1c993ba0..8199f271 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -578,6 +578,12 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | "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 @@ -585,6 +591,12 @@ let instruction_analysis top_level end_flag thunk_name regn_to_reg_details regis | "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") _) _ _ -- cgit v1.2.3 From 29182cd14e228529b3e26ef901e927bde8d27345 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 24 Oct 2017 15:44:10 +0100 Subject: fix default cap value on cheri128 following previous changes -- E stored in registers is no longer xored with 48 so need to initialise it. Also use E and T values used by CHERI hw and adjust decoding functions appropriately. Fix shift functions for ocaml shallow embedding which failed to handle shifts greater than vector length. --- src/gen_lib/sail_values.ml | 27 +++++++++++++++++---------- src/lem_interp/run_with_elf_cheri128.ml | 2 +- 2 files changed, 18 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/gen_lib/sail_values.ml b/src/gen_lib/sail_values.ml index d160e84a..213acea1 100644 --- a/src/gen_lib/sail_values.ml +++ b/src/gen_lib/sail_values.ml @@ -889,18 +889,25 @@ let shift_op_vec_int op (l,r) = let len = Array.length array in (match op with | "<<" -> - let left = Array.sub array r (len - r) in - let right = Array.make r Vzero in - let result = Array.append left right in - Vvector(result, start, ord) + if (r <= len) then + let left = Array.sub array r (len - r) in + let right = Array.make r Vzero in + let result = Array.append left right in + Vvector(result, start, ord) + else + Vvector(Array.make len Vzero, start, ord) | ">>" -> - let left = Array.make r Vzero in - let right = Array.sub array 0 (len - r) in - let result = Array.append left right in - Vvector(result, start, ord) + if (r <= len) then + let left = Array.make r Vzero in + let right = Array.sub array 0 (len - r) in + let result = Array.append left right in + Vvector(result, start, ord) + else + Vvector(Array.make len Vzero, start, ord) | "<<<" -> - let left = Array.sub array r (len - r) in - let right = Array.sub array 0 r in + let rmod = r mod len in + let left = Array.sub array rmod (len - rmod) in + let right = Array.sub array 0 rmod in let result = Array.append left right in Vvector(result, start, ord) | _ -> assert false) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 3ad507bc..f4f319ea 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -665,7 +665,7 @@ let cheri_register_data_all = mips_register_data_all @ [ let initial_stack_and_reg_data_of_MIPS_elf_file e_entry all_data_memory = let initial_stack_data = [] in - let initial_cap_val_int = Nat_big_num.of_string "0x1fffe0000000800000000000000000000" in (* hex((0x80000 << 64) + (0x7fff << 113) + (1 << 128)) *) + let initial_cap_val_int = Nat_big_num.of_string "0x1fffe6000000100000000000000000000" in (* hex((0x10000 << 64) + (48 << 105) + (0x7fff << 113) + (1 << 128)) T=0x10000 E=48 perms=0x7fff tag=1 *) let initial_cap_val_reg = Sail_impl_base.register_value_of_integer 129 128 D_decreasing initial_cap_val_int in let initial_register_abi_data : (string * Sail_impl_base.register_value) list = [ ("CP0Status", Sail_impl_base.register_value_of_integer 32 31 D_decreasing (Nat_big_num.of_string "0x00400000")); -- cgit v1.2.3 From a35692d69681683c2bffe7c824ad230b88679ed9 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Tue, 31 Oct 2017 16:09:46 +0000 Subject: cheri: throw an exception if there is an attempt to access C26/IDC in the delay slot of a ccall selector 1 call. --- src/lem_interp/run_with_elf_cheri.ml | 2 ++ src/lem_interp/run_with_elf_cheri128.ml | 2 ++ 2 files changed, 4 insertions(+) (limited to 'src') diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index b879f702..b50cb01d 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -493,6 +493,7 @@ let mips_register_data_all = [ ("PC", (D_decreasing, 64, 63)); ("branchPending", (D_decreasing, 1, 0)); ("inBranchDelay", (D_decreasing, 1, 0)); + ("inCCallDelay", (D_decreasing, 1, 0)); ("delayedPC", (D_decreasing, 64, 63)); ("nextPC", (D_decreasing, 64, 63)); (* General purpose registers *) @@ -1072,6 +1073,7 @@ let set_next_instruction_address model = begin reg := Reg.add "nextPC" n_pc !reg; reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; end | (Some pc_val, Some 1) -> (* delay slot -- branch to delayed PC and clear branchPending *) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index f4f319ea..148b29ae 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -493,6 +493,7 @@ let mips_register_data_all = [ ("PC", (D_decreasing, 64, 63)); ("branchPending", (D_decreasing, 1, 0)); ("inBranchDelay", (D_decreasing, 1, 0)); + ("inCCallDelay", (D_decreasing, 1, 0)); ("delayedPC", (D_decreasing, 64, 63)); ("nextPC", (D_decreasing, 64, 63)); (* General purpose registers *) @@ -1072,6 +1073,7 @@ let set_next_instruction_address model = begin reg := Reg.add "nextPC" n_pc !reg; reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; end | (Some pc_val, Some 1) -> (* delay slot -- branch to delayed PC and clear branchPending *) -- cgit v1.2.3 From 8e5d44d17c71cf946e65e15de8df42de2af4c652 Mon Sep 17 00:00:00 2001 From: Shaked Flur Date: Wed, 1 Nov 2017 14:17:08 +0000 Subject: added RISC-V "fence r,r" --- src/gen_lib/deep_shallow_convert.lem | 10 ++++++---- src/lem_interp/sail_impl_base.lem | 11 +++++++---- 2 files changed, 13 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/gen_lib/deep_shallow_convert.lem b/src/gen_lib/deep_shallow_convert.lem index 5a0dd99e..76880dbd 100644 --- a/src/gen_lib/deep_shallow_convert.lem +++ b/src/gen_lib/deep_shallow_convert.lem @@ -471,10 +471,11 @@ let barrier_kindToInterpValue = function | Barrier_MIPS_SYNC -> V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") Unknown) (T_id "barrier_kind") (C_Enum 12) (toInterpValue ()) | Barrier_RISCV_rw_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") Unknown) (T_id "barrier_kind") (C_Enum 13) (toInterpValue ()) | Barrier_RISCV_r_rw -> V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") Unknown) (T_id "barrier_kind") (C_Enum 14) (toInterpValue ()) - | Barrier_RISCV_rw_w -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") Unknown) (T_id "barrier_kind") (C_Enum 15) (toInterpValue ()) - | Barrier_RISCV_w_w -> V_ctor (Id_aux (Id "Barrier_RISCV_w_w") Unknown) (T_id "barrier_kind") (C_Enum 16) (toInterpValue ()) - | Barrier_RISCV_i -> V_ctor (Id_aux (Id "Barrier_RISCV_i") Unknown) (T_id "barrier_kind") (C_Enum 17) (toInterpValue ()) - | Barrier_x86_MFENCE -> V_ctor (Id_aux (Id "Barrier_x86_MFENCE") Unknown) (T_id "barrier_kind") (C_Enum 18) (toInterpValue ()) + | Barrier_RISCV_r_r -> V_ctor (Id_aux (Id "Barrier_RISCV_r_r") Unknown) (T_id "barrier_kind") (C_Enum 15) (toInterpValue ()) + | Barrier_RISCV_rw_w -> V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") Unknown) (T_id "barrier_kind") (C_Enum 16) (toInterpValue ()) + | Barrier_RISCV_w_w -> V_ctor (Id_aux (Id "Barrier_RISCV_w_w") Unknown) (T_id "barrier_kind") (C_Enum 17) (toInterpValue ()) + | Barrier_RISCV_i -> V_ctor (Id_aux (Id "Barrier_RISCV_i") Unknown) (T_id "barrier_kind") (C_Enum 18) (toInterpValue ()) + | Barrier_x86_MFENCE -> V_ctor (Id_aux (Id "Barrier_x86_MFENCE") Unknown) (T_id "barrier_kind") (C_Enum 19) (toInterpValue ()) end let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_Sync") _) _ _ v -> Barrier_Sync @@ -492,6 +493,7 @@ let rec barrier_kindFromInterpValue v = match v with | V_ctor (Id_aux (Id "Barrier_MIPS_SYNC") _) _ _ v -> Barrier_MIPS_SYNC | V_ctor (Id_aux (Id "Barrier_RISCV_rw_rw") _) _ _ v -> Barrier_RISCV_rw_rw | V_ctor (Id_aux (Id "Barrier_RISCV_r_rw") _) _ _ v -> Barrier_RISCV_r_rw + | V_ctor (Id_aux (Id "Barrier_RISCV_r_r") _) _ _ v -> Barrier_RISCV_r_r | V_ctor (Id_aux (Id "Barrier_RISCV_rw_w") _) _ _ v -> Barrier_RISCV_rw_w | V_ctor (Id_aux (Id "Barrier_RISCV_w_w") _) _ _ v -> Barrier_RISCV_w_w | V_ctor (Id_aux (Id "Barrier_RISCV_i") _) _ _ v -> Barrier_RISCV_i diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 4f07f574..c0ec8548 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -501,6 +501,7 @@ type barrier_kind = (* 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_i @@ -525,6 +526,7 @@ instance (Show barrier_kind) | 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_i -> "Barrier_RISCV_i" @@ -621,10 +623,11 @@ instance (EnumerationType barrier_kind) | Barrier_MIPS_SYNC -> 12 | Barrier_RISCV_rw_rw -> 13 | Barrier_RISCV_r_rw -> 14 - | Barrier_RISCV_rw_w -> 15 - | Barrier_RISCV_w_w -> 16 - | Barrier_RISCV_i -> 17 - | Barrier_x86_MFENCE -> 18 + | Barrier_RISCV_r_r -> 15 + | Barrier_RISCV_rw_w -> 16 + | Barrier_RISCV_w_w -> 17 + | Barrier_RISCV_i -> 18 + | Barrier_x86_MFENCE -> 19 end end -- cgit v1.2.3 From d91841f80740b210c673d3138f77b9d4d5684102 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 2 Nov 2017 14:06:24 +0000 Subject: reset inCCallDelay in code that is not dead. --- src/lem_interp/run_with_elf_cheri.ml | 1 + src/lem_interp/run_with_elf_cheri128.ml | 1 + 2 files changed, 2 insertions(+) (limited to 'src') diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index b50cb01d..8f7d5505 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -1285,6 +1285,7 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let npc_addr = add_address_nat pc_val 4 in let npc_reg = register_value_of_address npc_addr Sail_impl_base.D_decreasing in reg := Reg.add "nextPC" npc_reg !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; | Some 1 -> reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 148b29ae..311d6f69 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -1285,6 +1285,7 @@ let rec fde_loop count context model mode track_dependencies addr_trans = let npc_addr = add_address_nat pc_val 4 in let npc_reg = register_value_of_address npc_addr Sail_impl_base.D_decreasing in reg := Reg.add "nextPC" npc_reg !reg; + reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; | Some 1 -> reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; -- cgit v1.2.3 From 5d59b0c1a477c2d9e1abcfc6fb1b51dff32bd9b5 Mon Sep 17 00:00:00 2001 From: Robert Norton Date: Thu, 2 Nov 2017 14:47:30 +0000 Subject: remove a lot of dead code form run_with_elf_cheri* --- src/lem_interp/run_with_elf_cheri.ml | 568 ------------------------------- src/lem_interp/run_with_elf_cheri128.ml | 570 -------------------------------- 2 files changed, 1138 deletions(-) (limited to 'src') diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index 8f7d5505..7750c16c 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -124,369 +124,6 @@ let register_state_zero register_data rbn : register_value = in register_value_zeros dir width start_index type model = PPC | AArch64 | MIPS -(* -let ppc_register_data_all = [ - (*Pseudo registers*) - ("CIA", (D_increasing, 64, 0)); - ("NIA", (D_increasing, 64, 0)); - ("mode64bit", (D_increasing, 1, 0)); - ("bigendianmode", (D_increasing, 1, 0)); - (* special registers *) - ("CR", (D_increasing, 32, 32)); - ("CTR", (D_increasing, 64, 0 )); - ("LR", (D_increasing, 64, 0 )); - ("XER", (D_increasing, 64, 0 )); - ("VRSAVE",(D_increasing, 32, 32)); - ("FPSCR", (D_increasing, 64, 0 )); - ("VSCR", (D_increasing, 32, 96)); - - (* general purpose registers *) - ("GPR0", (D_increasing, 64, 0 )); - ("GPR1", (D_increasing, 64, 0 )); - ("GPR2", (D_increasing, 64, 0 )); - ("GPR3", (D_increasing, 64, 0 )); - ("GPR4", (D_increasing, 64, 0 )); - ("GPR5", (D_increasing, 64, 0 )); - ("GPR6", (D_increasing, 64, 0 )); - ("GPR7", (D_increasing, 64, 0 )); - ("GPR8", (D_increasing, 64, 0 )); - ("GPR9", (D_increasing, 64, 0 )); - ("GPR10", (D_increasing, 64, 0 )); - ("GPR11", (D_increasing, 64, 0 )); - ("GPR12", (D_increasing, 64, 0 )); - ("GPR13", (D_increasing, 64, 0 )); - ("GPR14", (D_increasing, 64, 0 )); - ("GPR15", (D_increasing, 64, 0 )); - ("GPR16", (D_increasing, 64, 0 )); - ("GPR17", (D_increasing, 64, 0 )); - ("GPR18", (D_increasing, 64, 0 )); - ("GPR19", (D_increasing, 64, 0 )); - ("GPR20", (D_increasing, 64, 0 )); - ("GPR21", (D_increasing, 64, 0 )); - ("GPR22", (D_increasing, 64, 0 )); - ("GPR23", (D_increasing, 64, 0 )); - ("GPR24", (D_increasing, 64, 0 )); - ("GPR25", (D_increasing, 64, 0 )); - ("GPR26", (D_increasing, 64, 0 )); - ("GPR27", (D_increasing, 64, 0 )); - ("GPR28", (D_increasing, 64, 0 )); - ("GPR29", (D_increasing, 64, 0 )); - ("GPR30", (D_increasing, 64, 0 )); - ("GPR31", (D_increasing, 64, 0 )); - (* vector registers *) - ("VR0", (D_increasing, 128, 0 )); - ("VR1", (D_increasing, 128, 0 )); - ("VR2", (D_increasing, 128, 0 )); - ("VR3", (D_increasing, 128, 0 )); - ("VR4", (D_increasing, 128, 0 )); - ("VR5", (D_increasing, 128, 0 )); - ("VR6", (D_increasing, 128, 0 )); - ("VR7", (D_increasing, 128, 0 )); - ("VR8", (D_increasing, 128, 0 )); - ("VR9", (D_increasing, 128, 0 )); - ("VR10", (D_increasing, 128, 0 )); - ("VR11", (D_increasing, 128, 0 )); - ("VR12", (D_increasing, 128, 0 )); - ("VR13", (D_increasing, 128, 0 )); - ("VR14", (D_increasing, 128, 0 )); - ("VR15", (D_increasing, 128, 0 )); - ("VR16", (D_increasing, 128, 0 )); - ("VR17", (D_increasing, 128, 0 )); - ("VR18", (D_increasing, 128, 0 )); - ("VR19", (D_increasing, 128, 0 )); - ("VR20", (D_increasing, 128, 0 )); - ("VR21", (D_increasing, 128, 0 )); - ("VR22", (D_increasing, 128, 0 )); - ("VR23", (D_increasing, 128, 0 )); - ("VR24", (D_increasing, 128, 0 )); - ("VR25", (D_increasing, 128, 0 )); - ("VR26", (D_increasing, 128, 0 )); - ("VR27", (D_increasing, 128, 0 )); - ("VR28", (D_increasing, 128, 0 )); - ("VR29", (D_increasing, 128, 0 )); - ("VR30", (D_increasing, 128, 0 )); - ("VR31", (D_increasing, 128, 0 )); - (* floating-point registers *) - ("FPR0", (D_increasing, 64, 0 )); - ("FPR1", (D_increasing, 64, 0 )); - ("FPR2", (D_increasing, 64, 0 )); - ("FPR3", (D_increasing, 64, 0 )); - ("FPR4", (D_increasing, 64, 0 )); - ("FPR5", (D_increasing, 64, 0 )); - ("FPR6", (D_increasing, 64, 0 )); - ("FPR7", (D_increasing, 64, 0 )); - ("FPR8", (D_increasing, 64, 0 )); - ("FPR9", (D_increasing, 64, 0 )); - ("FPR10", (D_increasing, 64, 0 )); - ("FPR11", (D_increasing, 64, 0 )); - ("FPR12", (D_increasing, 64, 0 )); - ("FPR13", (D_increasing, 64, 0 )); - ("FPR14", (D_increasing, 64, 0 )); - ("FPR15", (D_increasing, 64, 0 )); - ("FPR16", (D_increasing, 64, 0 )); - ("FPR17", (D_increasing, 64, 0 )); - ("FPR18", (D_increasing, 64, 0 )); - ("FPR19", (D_increasing, 64, 0 )); - ("FPR20", (D_increasing, 64, 0 )); - ("FPR21", (D_increasing, 64, 0 )); - ("FPR22", (D_increasing, 64, 0 )); - ("FPR23", (D_increasing, 64, 0 )); - ("FPR24", (D_increasing, 64, 0 )); - ("FPR25", (D_increasing, 64, 0 )); - ("FPR26", (D_increasing, 64, 0 )); - ("FPR27", (D_increasing, 64, 0 )); - ("FPR28", (D_increasing, 64, 0 )); - ("FPR29", (D_increasing, 64, 0 )); - ("FPR30", (D_increasing, 64, 0 )); - ("FPR31", (D_increasing, 64, 0 )); -] - -let initial_stack_and_reg_data_of_PPC_elf_file e_entry all_data_memory = - (* set up initial registers, per 3.4.1 of 64-bit PowerPC ELF Application Binary Interface Supplement 1.9 *) - - let auxiliary_vector_space = Nat_big_num.of_string "17592186042368" (*"0xffffffff800"*) in - (* notionally there should be at least an AT_NULL auxiliary vector entry there, but our examples will never read it *) - - (* take start of stack roughly where running gdb on hello5 on bim says it is*) - let initial_GPR1_stack_pointer = Nat_big_num.of_string "17592186040320" (*"0xffffffff000"*) in - let initial_GPR1_stack_pointer_value = - Sail_impl_base.register_value_of_integer 64 0 Sail_impl_base.D_increasing initial_GPR1_stack_pointer in - (* ELF says we need an initial zero doubleword there *) - let initial_stack_data = - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - (* this is a fairly big but arbitrary chunk *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - (* this is the stack memory that test 1938 actually uses *) - [ ("initial_stack_data1", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128), - Lem_list.replicate 8 0 ); - ("initial_stack_data2", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 8), - Lem_list.replicate 8 0 ); - ("initial_stack_data3", Nat_big_num.add initial_GPR1_stack_pointer (Nat_big_num.of_int 16), - Lem_list.replicate 8 0 )] in - - (* read TOC from the second field of the function descriptor pointed to by e_entry*) - let initial_GPR2_TOC = - Sail_impl_base.register_value_of_address - (Sail_impl_base.address_of_byte_list - (List.map (fun b -> match b with Some b -> b | None -> failwith "Address had undefined") - (List.map byte_of_byte_lifted - (read_mem all_data_memory - (Nat_big_num.add (Nat_big_num.of_int 8) e_entry) 8)))) - Sail_impl_base.D_increasing in - (* these initial register values are all mandated to be zero, but that's handled by the generic zeroing below - let initial_GPR3_argc = (Nat_big_num.of_int 0) in - let initial_GPR4_argv = (Nat_big_num.of_int 0) in - let initial_GPR5_envp = (Nat_big_num.of_int 0) in - let initial_FPSCR = (Nat_big_num.of_int 0) in - *) - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [ ("GPR1", initial_GPR1_stack_pointer_value); - ("GPR2", initial_GPR2_TOC); - (* - ("GPR3", initial_GPR3_argc); - ("GPR4", initial_GPR4_argv); - ("GPR5", initial_GPR5_envp); - ("FPSCR", initial_FPSCR); - *) - ] in - - (initial_stack_data, initial_register_abi_data) - - -let aarch64_reg bit_count name = (name, (D_decreasing, bit_count, bit_count - 1)) - -let aarch64_PC_data = [aarch64_reg 64 "_PC"] - -(* most of the PSTATE fields are aliases to other registers so they - don't appear here *) -let aarch64_PSTATE_data = [ - aarch64_reg 1 "PSTATE_nRW"; - aarch64_reg 1 "PSTATE_E"; - aarch64_reg 5 "PSTATE_M"; -] - -let aarch64_general_purpose_registers_data = [ - aarch64_reg 64 "R0"; - aarch64_reg 64 "R1"; - aarch64_reg 64 "R2"; - aarch64_reg 64 "R3"; - aarch64_reg 64 "R4"; - aarch64_reg 64 "R5"; - aarch64_reg 64 "R6"; - aarch64_reg 64 "R7"; - aarch64_reg 64 "R8"; - aarch64_reg 64 "R9"; - aarch64_reg 64 "R10"; - aarch64_reg 64 "R11"; - aarch64_reg 64 "R12"; - aarch64_reg 64 "R13"; - aarch64_reg 64 "R14"; - aarch64_reg 64 "R15"; - aarch64_reg 64 "R16"; - aarch64_reg 64 "R17"; - aarch64_reg 64 "R18"; - aarch64_reg 64 "R19"; - aarch64_reg 64 "R20"; - aarch64_reg 64 "R21"; - aarch64_reg 64 "R22"; - aarch64_reg 64 "R23"; - aarch64_reg 64 "R24"; - aarch64_reg 64 "R25"; - aarch64_reg 64 "R26"; - aarch64_reg 64 "R27"; - aarch64_reg 64 "R28"; - aarch64_reg 64 "R29"; - aarch64_reg 64 "R30"; -] - -let aarch64_SIMD_registers_data = [ - aarch64_reg 128 "V0"; - aarch64_reg 128 "V1"; - aarch64_reg 128 "V2"; - aarch64_reg 128 "V3"; - aarch64_reg 128 "V4"; - aarch64_reg 128 "V5"; - aarch64_reg 128 "V6"; - aarch64_reg 128 "V7"; - aarch64_reg 128 "V8"; - aarch64_reg 128 "V9"; - aarch64_reg 128 "V10"; - aarch64_reg 128 "V11"; - aarch64_reg 128 "V12"; - aarch64_reg 128 "V13"; - aarch64_reg 128 "V14"; - aarch64_reg 128 "V15"; - aarch64_reg 128 "V16"; - aarch64_reg 128 "V17"; - aarch64_reg 128 "V18"; - aarch64_reg 128 "V19"; - aarch64_reg 128 "V20"; - aarch64_reg 128 "V21"; - aarch64_reg 128 "V22"; - aarch64_reg 128 "V23"; - aarch64_reg 128 "V24"; - aarch64_reg 128 "V25"; - aarch64_reg 128 "V26"; - aarch64_reg 128 "V27"; - aarch64_reg 128 "V28"; - aarch64_reg 128 "V29"; - aarch64_reg 128 "V30"; - aarch64_reg 128 "V31"; -] - -let aarch64_special_purpose_registers_data = [ - aarch64_reg 32 "CurrentEL"; - aarch64_reg 32 "DAIF"; - aarch64_reg 32 "NZCV"; - aarch64_reg 64 "SP_EL0"; - aarch64_reg 64 "SP_EL1"; - aarch64_reg 64 "SP_EL2"; - aarch64_reg 64 "SP_EL3"; - aarch64_reg 32 "SPSel"; - aarch64_reg 32 "SPSR_EL1"; - aarch64_reg 32 "SPSR_EL2"; - aarch64_reg 32 "SPSR_EL3"; - aarch64_reg 64 "ELR_EL1"; - aarch64_reg 64 "ELR_EL2"; - aarch64_reg 64 "ELR_EL3"; -] - -let aarch64_general_system_control_registers_data = [ - aarch64_reg 64 "HCR_EL2"; - aarch64_reg 64 "ID_AA64MMFR0_EL1"; - aarch64_reg 64 "RVBAR_EL1"; - aarch64_reg 64 "RVBAR_EL2"; - aarch64_reg 64 "RVBAR_EL3"; - aarch64_reg 32 "SCR_EL3"; - aarch64_reg 32 "SCTLR_EL1"; - aarch64_reg 32 "SCTLR_EL2"; - aarch64_reg 32 "SCTLR_EL3"; - aarch64_reg 64 "TCR_EL1"; - aarch64_reg 32 "TCR_EL2"; - aarch64_reg 32 "TCR_EL3"; -] - -let aarch64_debug_registers_data = [ - aarch64_reg 32 "DBGPRCR_EL1"; - aarch64_reg 32 "OSDLR_EL1"; -] - -let aarch64_performance_monitors_registers_data = [] -let aarch64_generic_timer_registers_data = [] -let aarch64_generic_interrupt_controller_CPU_interface_registers_data = [] - -let aarch64_external_debug_registers_data = [ - aarch64_reg 32 "EDSCR"; -] - -let aarch32_general_system_control_registers_data = [ - aarch64_reg 32 "SCR"; -] - -let aarch32_debug_registers_data = [ - aarch64_reg 32 "DBGOSDLR"; - aarch64_reg 32 "DBGPRCR"; -] - -let aarch64_register_data_all = - aarch64_PC_data @ - aarch64_PSTATE_data @ - aarch64_general_purpose_registers_data @ - aarch64_SIMD_registers_data @ - aarch64_special_purpose_registers_data @ - aarch64_general_system_control_registers_data @ - aarch64_debug_registers_data @ - aarch64_performance_monitors_registers_data @ - aarch64_generic_timer_registers_data @ - aarch64_generic_interrupt_controller_CPU_interface_registers_data @ - aarch64_external_debug_registers_data @ - aarch32_general_system_control_registers_data @ - aarch32_debug_registers_data - -let initial_stack_and_reg_data_of_AAarch64_elf_file e_entry all_data_memory = - let (reg_SP_EL0_direction, reg_SP_EL0_width, reg_SP_EL0_initial_index) = - List.assoc "SP_EL0" aarch64_register_data_all in - - (* we compiled a small program that prints out SP and run it a few - times on the Nexus9, these are the results: - 0x0000007fe7f903e0 - 0x0000007fdcdbf3f0 - 0x0000007fcbe1ba90 - 0x0000007fcf378280 - 0x0000007fdd54b8d0 - 0x0000007fd961bc10 - 0x0000007ff3be6350 - 0x0000007fd6bf6ef0 - 0x0000007fff7676f0 - 0x0000007ff2c34560 *) - let initial_SP_EL0 = Nat_big_num.of_string "549739036672" (*"0x0000007fff000000"*) in - let initial_SP_EL0_value = - Sail_impl_base.register_value_of_integer - reg_SP_EL0_width - reg_SP_EL0_initial_index - reg_SP_EL0_direction - initial_SP_EL0 - in - - (* ELF says we need an initial zero doubleword there *) - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - let initial_stack_data = - (* this is a fairly big but arbitrary chunk: *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - - [ ("initial_stack_data1", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 16), Lem_list.replicate 8 0); - ("initial_stack_data2", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 8), Lem_list.replicate 8 0) - ] - in - - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [("SP_EL0", initial_SP_EL0_value)] - in - - (initial_stack_data, initial_register_abi_data) -*) let mips_register_data_all = [ (*Pseudo registers*) @@ -749,50 +386,6 @@ let initial_system_state_of_elf_file name = let (isa_defs, isa_memory_access, isa_externs, isa_model, model_reg_d, startaddr, initial_stack_data, initial_register_abi_data, register_data_all) = match Nat_big_num.to_int e_machine with -(* | 21 (* EM_PPC64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_power64.abi_power64_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_PPC_elf_file e_entry !data_mem in - - (Power.defs, - (Power_extras.read_memory_functions,Power_extras.memory_writes,[],[],Power_extras.barrier_functions), - Power_extras.power_externs, - PPC, - D_increasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - ppc_register_data_all) - - | 183 (* EM_AARCH64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_aarch64_le.abi_aarch64_le_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_AAarch64_elf_file e_entry !data_mem in - - (ArmV8.defs, - (ArmV8_extras.aArch64_read_memory_functions, - ArmV8_extras.aArch64_memory_writes, - ArmV8_extras.aArch64_memory_eas, - ArmV8_extras.aArch64_memory_vals, - ArmV8_extras.aArch64_barrier_functions), - [], - AArch64, - D_decreasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - aarch64_register_data_all) *) | 8 (* EM_MIPS *) -> let startaddr = let e_entry = Uint64.of_string (Nat_big_num.to_string e_entry) in @@ -889,50 +482,6 @@ let initial_system_state_of_elf_file name = in - (* Now we examine the rest of the data memory, - removing the footprint of the symbols and chunking it into aligned chunks *) - - let rec remove_symbols_from_data_memory data_mem symbols = - match symbols with - | [] -> data_mem - | (name,address,size,bs)::symbols' -> - let data_mem' = - Mem.filter - (fun a v -> - not (Nat_big_num.greater_equal a address && - Nat_big_num.less a (Nat_big_num.add (Nat_big_num.of_int (List.length bs)) address))) - data_mem in - remove_symbols_from_data_memory data_mem' symbols' in - - let trimmed_data_memory : (Nat_big_num.num * memory_byte) list = - Mem.bindings (remove_symbols_from_data_memory !data_mem symbol_table) in - - (* make sure that's ordered increasingly.... *) - let trimmed_data_memory = - List.sort (fun (a,b) (a',b') -> Nat_big_num.compare a a') trimmed_data_memory in - - let aligned a n = (* a mod n = 0 *) - let n_big = Nat_big_num.of_int n in - Nat_big_num.equal (Nat_big_num.modulus a n_big) ((Nat_big_num.of_int 0)) in - - let isplus a' a n = (* a' = a+n *) - Nat_big_num.equal a' (Nat_big_num.add (Nat_big_num.of_int n) a) in - - let rec chunk_data_memory dm = - match dm with - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::(a4,b4)::(a5,b5)::(a6,b6)::(a7,b7)::dm' when - (aligned a0 8 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3 && - isplus a4 a0 4 && isplus a5 a0 5 && isplus a6 a0 6 && isplus a7 a0 7) -> - (a0,8,[b0;b1;b2;b3;b4;b5;b6;b7]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::dm' when - (aligned a0 4 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3) -> - (a0,4,[b0;b1;b2;b3]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::dm' when - (aligned a0 2 && isplus a1 a0 1) -> - (a0,2,[b0;b1]) :: chunk_data_memory dm' - | (a0,b0)::dm' -> - (a0,1,[b0]):: chunk_data_memory dm' - | [] -> [] in let initial_register_state = fun rbn -> @@ -1022,69 +571,10 @@ let stop_condition_met model instr = true | _ -> false) -let is_branch model instruction = - let (name,_,_) = instruction in - match (model , name) with - | (PPC, "B") -> true - | (PPC, "Bc") -> true - | (PPC, "Bclr") -> true - | (PPC, "Bcctr") -> true - | (PPC, _) -> false - | (AArch64, "BranchImmediate") -> true - | (AArch64, "BranchConditional") -> true - | (AArch64, "CompareAndBranch") -> true - | (AArch64, "TestBitAndBranch") -> true - | (AArch64, "BranchRegister") -> true - | (AArch64, _) -> false - | (MIPS, _) -> false (*todo,fill this in*) - let option_int_of_option_integer i = match i with | Some i -> Some (Nat_big_num.to_int i) | None -> None -let set_next_instruction_address model = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let nia_addr = add_address_nat cia_addr 4 in - let nia = register_value_of_address nia_addr Sail_impl_base.D_increasing in - reg := Reg.add "NIA" nia !reg - | _ -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let n_addr = add_address_nat pc_addr 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - reg := Reg.add "_PC" n_pc !reg - | _ -> failwith "_PC address contains unknown or undefined") - | MIPS -> - let pc_addr = address_of_register_value (Reg.find "PC" !reg) in - let branchPending = integer_of_register_value (Reg.find "branchPending" !reg) in - (match (pc_addr, option_int_of_option_integer branchPending) with - | (Some pc_val, Some 0) -> - (* normal -- increment PC *) - let n_addr = add_address_nat pc_val 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - begin - reg := Reg.add "nextPC" n_pc !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - end - | (Some pc_val, Some 1) -> - (* delay slot -- branch to delayed PC and clear branchPending *) - begin - reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; - reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; - reg := Reg.add "branchPending" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing (Nat_big_num.of_int 1)) !reg; - end - | (_, _) -> errorf "PC address contains unknown or undefined"; exit 1) - let add1 = Nat_big_num.add (Nat_big_num.of_int 1) let get_addr_trans_regs _ = @@ -1194,68 +684,10 @@ let rec write_events = function | _ -> failwith "Only register write events expected"); write_events events -let fetch_instruction_opcode_and_update_ia model addr_trans = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let cia_a = integer_of_address cia_addr in - let opcode = (get_opcode cia_a) in - begin - reg := Reg.add "CIA" (Reg.find "NIA" !reg) !reg; - Opcode opcode - end - | None -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let pc_a = integer_of_address pc_addr in - let opcode = (get_opcode pc_a) in - Opcode opcode - | None -> failwith "_PC address contains unknown or undefined") - | MIPS -> - begin - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let nextPC = Reg.find "nextPC" !reg in - let pc_addr = address_of_register_value nextPC in - (*let unused = interactf "PC: %s\n" (Printing_functions.register_value_to_string nextPC) in*) - (match pc_addr with - | Some pc_addr -> - let pc_a = match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, Some events -> - write_events (List.rev events); - let nextPC = Reg.find "nextPC" !reg in - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let pc_addr = address_of_register_value nextPC in - (match pc_addr with - | Some pc_addr -> - (match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, _ -> failwith "Address translation failed twice") - | None -> failwith "no nextPc address") - | _ -> failwith "No address and no events from translate address" - in - let opcode = (get_opcode pc_a) in - begin - reg := Reg.add "PC" (Reg.find "nextPC" !reg) !reg; - Opcode opcode - end - | None -> errorf "nextPC contains unknown or undefined"; exit 1) - end - | _ -> assert false - let get_pc_address = function | MIPS -> Reg.find "PC" !reg | PPC -> Reg.find "CIA" !reg | AArch64 -> Reg.find "_PC" !reg - let option_int_of_reg str = option_int_of_option_integer (integer_of_register_value (Reg.find str !reg)) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 311d6f69..6dca80f4 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -124,369 +124,6 @@ let register_state_zero register_data rbn : register_value = in register_value_zeros dir width start_index type model = PPC | AArch64 | MIPS -(* -let ppc_register_data_all = [ - (*Pseudo registers*) - ("CIA", (D_increasing, 64, 0)); - ("NIA", (D_increasing, 64, 0)); - ("mode64bit", (D_increasing, 1, 0)); - ("bigendianmode", (D_increasing, 1, 0)); - (* special registers *) - ("CR", (D_increasing, 32, 32)); - ("CTR", (D_increasing, 64, 0 )); - ("LR", (D_increasing, 64, 0 )); - ("XER", (D_increasing, 64, 0 )); - ("VRSAVE",(D_increasing, 32, 32)); - ("FPSCR", (D_increasing, 64, 0 )); - ("VSCR", (D_increasing, 32, 96)); - - (* general purpose registers *) - ("GPR0", (D_increasing, 64, 0 )); - ("GPR1", (D_increasing, 64, 0 )); - ("GPR2", (D_increasing, 64, 0 )); - ("GPR3", (D_increasing, 64, 0 )); - ("GPR4", (D_increasing, 64, 0 )); - ("GPR5", (D_increasing, 64, 0 )); - ("GPR6", (D_increasing, 64, 0 )); - ("GPR7", (D_increasing, 64, 0 )); - ("GPR8", (D_increasing, 64, 0 )); - ("GPR9", (D_increasing, 64, 0 )); - ("GPR10", (D_increasing, 64, 0 )); - ("GPR11", (D_increasing, 64, 0 )); - ("GPR12", (D_increasing, 64, 0 )); - ("GPR13", (D_increasing, 64, 0 )); - ("GPR14", (D_increasing, 64, 0 )); - ("GPR15", (D_increasing, 64, 0 )); - ("GPR16", (D_increasing, 64, 0 )); - ("GPR17", (D_increasing, 64, 0 )); - ("GPR18", (D_increasing, 64, 0 )); - ("GPR19", (D_increasing, 64, 0 )); - ("GPR20", (D_increasing, 64, 0 )); - ("GPR21", (D_increasing, 64, 0 )); - ("GPR22", (D_increasing, 64, 0 )); - ("GPR23", (D_increasing, 64, 0 )); - ("GPR24", (D_increasing, 64, 0 )); - ("GPR25", (D_increasing, 64, 0 )); - ("GPR26", (D_increasing, 64, 0 )); - ("GPR27", (D_increasing, 64, 0 )); - ("GPR28", (D_increasing, 64, 0 )); - ("GPR29", (D_increasing, 64, 0 )); - ("GPR30", (D_increasing, 64, 0 )); - ("GPR31", (D_increasing, 64, 0 )); - (* vector registers *) - ("VR0", (D_increasing, 128, 0 )); - ("VR1", (D_increasing, 128, 0 )); - ("VR2", (D_increasing, 128, 0 )); - ("VR3", (D_increasing, 128, 0 )); - ("VR4", (D_increasing, 128, 0 )); - ("VR5", (D_increasing, 128, 0 )); - ("VR6", (D_increasing, 128, 0 )); - ("VR7", (D_increasing, 128, 0 )); - ("VR8", (D_increasing, 128, 0 )); - ("VR9", (D_increasing, 128, 0 )); - ("VR10", (D_increasing, 128, 0 )); - ("VR11", (D_increasing, 128, 0 )); - ("VR12", (D_increasing, 128, 0 )); - ("VR13", (D_increasing, 128, 0 )); - ("VR14", (D_increasing, 128, 0 )); - ("VR15", (D_increasing, 128, 0 )); - ("VR16", (D_increasing, 128, 0 )); - ("VR17", (D_increasing, 128, 0 )); - ("VR18", (D_increasing, 128, 0 )); - ("VR19", (D_increasing, 128, 0 )); - ("VR20", (D_increasing, 128, 0 )); - ("VR21", (D_increasing, 128, 0 )); - ("VR22", (D_increasing, 128, 0 )); - ("VR23", (D_increasing, 128, 0 )); - ("VR24", (D_increasing, 128, 0 )); - ("VR25", (D_increasing, 128, 0 )); - ("VR26", (D_increasing, 128, 0 )); - ("VR27", (D_increasing, 128, 0 )); - ("VR28", (D_increasing, 128, 0 )); - ("VR29", (D_increasing, 128, 0 )); - ("VR30", (D_increasing, 128, 0 )); - ("VR31", (D_increasing, 128, 0 )); - (* floating-point registers *) - ("FPR0", (D_increasing, 64, 0 )); - ("FPR1", (D_increasing, 64, 0 )); - ("FPR2", (D_increasing, 64, 0 )); - ("FPR3", (D_increasing, 64, 0 )); - ("FPR4", (D_increasing, 64, 0 )); - ("FPR5", (D_increasing, 64, 0 )); - ("FPR6", (D_increasing, 64, 0 )); - ("FPR7", (D_increasing, 64, 0 )); - ("FPR8", (D_increasing, 64, 0 )); - ("FPR9", (D_increasing, 64, 0 )); - ("FPR10", (D_increasing, 64, 0 )); - ("FPR11", (D_increasing, 64, 0 )); - ("FPR12", (D_increasing, 64, 0 )); - ("FPR13", (D_increasing, 64, 0 )); - ("FPR14", (D_increasing, 64, 0 )); - ("FPR15", (D_increasing, 64, 0 )); - ("FPR16", (D_increasing, 64, 0 )); - ("FPR17", (D_increasing, 64, 0 )); - ("FPR18", (D_increasing, 64, 0 )); - ("FPR19", (D_increasing, 64, 0 )); - ("FPR20", (D_increasing, 64, 0 )); - ("FPR21", (D_increasing, 64, 0 )); - ("FPR22", (D_increasing, 64, 0 )); - ("FPR23", (D_increasing, 64, 0 )); - ("FPR24", (D_increasing, 64, 0 )); - ("FPR25", (D_increasing, 64, 0 )); - ("FPR26", (D_increasing, 64, 0 )); - ("FPR27", (D_increasing, 64, 0 )); - ("FPR28", (D_increasing, 64, 0 )); - ("FPR29", (D_increasing, 64, 0 )); - ("FPR30", (D_increasing, 64, 0 )); - ("FPR31", (D_increasing, 64, 0 )); -] - -let initial_stack_and_reg_data_of_PPC_elf_file e_entry all_data_memory = - (* set up initial registers, per 3.4.1 of 64-bit PowerPC ELF Application Binary Interface Supplement 1.9 *) - - let auxiliary_vector_space = Nat_big_num.of_string "17592186042368" (*"0xffffffff800"*) in - (* notionally there should be at least an AT_NULL auxiliary vector entry there, but our examples will never read it *) - - (* take start of stack roughly where running gdb on hello5 on bim says it is*) - let initial_GPR1_stack_pointer = Nat_big_num.of_string "17592186040320" (*"0xffffffff000"*) in - let initial_GPR1_stack_pointer_value = - Sail_impl_base.register_value_of_integer 64 0 Sail_impl_base.D_increasing initial_GPR1_stack_pointer in - (* ELF says we need an initial zero doubleword there *) - let initial_stack_data = - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - (* this is a fairly big but arbitrary chunk *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - (* this is the stack memory that test 1938 actually uses *) - [ ("initial_stack_data1", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128), - Lem_list.replicate 8 0 ); - ("initial_stack_data2", Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 8), - Lem_list.replicate 8 0 ); - ("initial_stack_data3", Nat_big_num.add initial_GPR1_stack_pointer (Nat_big_num.of_int 16), - Lem_list.replicate 8 0 )] in - - (* read TOC from the second field of the function descriptor pointed to by e_entry*) - let initial_GPR2_TOC = - Sail_impl_base.register_value_of_address - (Sail_impl_base.address_of_byte_list - (List.map (fun b -> match b with Some b -> b | None -> failwith "Address had undefined") - (List.map byte_of_byte_lifted - (read_mem all_data_memory - (Nat_big_num.add (Nat_big_num.of_int 8) e_entry) 8)))) - Sail_impl_base.D_increasing in - (* these initial register values are all mandated to be zero, but that's handled by the generic zeroing below - let initial_GPR3_argc = (Nat_big_num.of_int 0) in - let initial_GPR4_argv = (Nat_big_num.of_int 0) in - let initial_GPR5_envp = (Nat_big_num.of_int 0) in - let initial_FPSCR = (Nat_big_num.of_int 0) in - *) - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [ ("GPR1", initial_GPR1_stack_pointer_value); - ("GPR2", initial_GPR2_TOC); - (* - ("GPR3", initial_GPR3_argc); - ("GPR4", initial_GPR4_argv); - ("GPR5", initial_GPR5_envp); - ("FPSCR", initial_FPSCR); - *) - ] in - - (initial_stack_data, initial_register_abi_data) - - -let aarch64_reg bit_count name = (name, (D_decreasing, bit_count, bit_count - 1)) - -let aarch64_PC_data = [aarch64_reg 64 "_PC"] - -(* most of the PSTATE fields are aliases to other registers so they - don't appear here *) -let aarch64_PSTATE_data = [ - aarch64_reg 1 "PSTATE_nRW"; - aarch64_reg 1 "PSTATE_E"; - aarch64_reg 5 "PSTATE_M"; -] - -let aarch64_general_purpose_registers_data = [ - aarch64_reg 64 "R0"; - aarch64_reg 64 "R1"; - aarch64_reg 64 "R2"; - aarch64_reg 64 "R3"; - aarch64_reg 64 "R4"; - aarch64_reg 64 "R5"; - aarch64_reg 64 "R6"; - aarch64_reg 64 "R7"; - aarch64_reg 64 "R8"; - aarch64_reg 64 "R9"; - aarch64_reg 64 "R10"; - aarch64_reg 64 "R11"; - aarch64_reg 64 "R12"; - aarch64_reg 64 "R13"; - aarch64_reg 64 "R14"; - aarch64_reg 64 "R15"; - aarch64_reg 64 "R16"; - aarch64_reg 64 "R17"; - aarch64_reg 64 "R18"; - aarch64_reg 64 "R19"; - aarch64_reg 64 "R20"; - aarch64_reg 64 "R21"; - aarch64_reg 64 "R22"; - aarch64_reg 64 "R23"; - aarch64_reg 64 "R24"; - aarch64_reg 64 "R25"; - aarch64_reg 64 "R26"; - aarch64_reg 64 "R27"; - aarch64_reg 64 "R28"; - aarch64_reg 64 "R29"; - aarch64_reg 64 "R30"; -] - -let aarch64_SIMD_registers_data = [ - aarch64_reg 128 "V0"; - aarch64_reg 128 "V1"; - aarch64_reg 128 "V2"; - aarch64_reg 128 "V3"; - aarch64_reg 128 "V4"; - aarch64_reg 128 "V5"; - aarch64_reg 128 "V6"; - aarch64_reg 128 "V7"; - aarch64_reg 128 "V8"; - aarch64_reg 128 "V9"; - aarch64_reg 128 "V10"; - aarch64_reg 128 "V11"; - aarch64_reg 128 "V12"; - aarch64_reg 128 "V13"; - aarch64_reg 128 "V14"; - aarch64_reg 128 "V15"; - aarch64_reg 128 "V16"; - aarch64_reg 128 "V17"; - aarch64_reg 128 "V18"; - aarch64_reg 128 "V19"; - aarch64_reg 128 "V20"; - aarch64_reg 128 "V21"; - aarch64_reg 128 "V22"; - aarch64_reg 128 "V23"; - aarch64_reg 128 "V24"; - aarch64_reg 128 "V25"; - aarch64_reg 128 "V26"; - aarch64_reg 128 "V27"; - aarch64_reg 128 "V28"; - aarch64_reg 128 "V29"; - aarch64_reg 128 "V30"; - aarch64_reg 128 "V31"; -] - -let aarch64_special_purpose_registers_data = [ - aarch64_reg 32 "CurrentEL"; - aarch64_reg 32 "DAIF"; - aarch64_reg 32 "NZCV"; - aarch64_reg 64 "SP_EL0"; - aarch64_reg 64 "SP_EL1"; - aarch64_reg 64 "SP_EL2"; - aarch64_reg 64 "SP_EL3"; - aarch64_reg 32 "SPSel"; - aarch64_reg 32 "SPSR_EL1"; - aarch64_reg 32 "SPSR_EL2"; - aarch64_reg 32 "SPSR_EL3"; - aarch64_reg 64 "ELR_EL1"; - aarch64_reg 64 "ELR_EL2"; - aarch64_reg 64 "ELR_EL3"; -] - -let aarch64_general_system_control_registers_data = [ - aarch64_reg 64 "HCR_EL2"; - aarch64_reg 64 "ID_AA64MMFR0_EL1"; - aarch64_reg 64 "RVBAR_EL1"; - aarch64_reg 64 "RVBAR_EL2"; - aarch64_reg 64 "RVBAR_EL3"; - aarch64_reg 32 "SCR_EL3"; - aarch64_reg 32 "SCTLR_EL1"; - aarch64_reg 32 "SCTLR_EL2"; - aarch64_reg 32 "SCTLR_EL3"; - aarch64_reg 64 "TCR_EL1"; - aarch64_reg 32 "TCR_EL2"; - aarch64_reg 32 "TCR_EL3"; -] - -let aarch64_debug_registers_data = [ - aarch64_reg 32 "DBGPRCR_EL1"; - aarch64_reg 32 "OSDLR_EL1"; -] - -let aarch64_performance_monitors_registers_data = [] -let aarch64_generic_timer_registers_data = [] -let aarch64_generic_interrupt_controller_CPU_interface_registers_data = [] - -let aarch64_external_debug_registers_data = [ - aarch64_reg 32 "EDSCR"; -] - -let aarch32_general_system_control_registers_data = [ - aarch64_reg 32 "SCR"; -] - -let aarch32_debug_registers_data = [ - aarch64_reg 32 "DBGOSDLR"; - aarch64_reg 32 "DBGPRCR"; -] - -let aarch64_register_data_all = - aarch64_PC_data @ - aarch64_PSTATE_data @ - aarch64_general_purpose_registers_data @ - aarch64_SIMD_registers_data @ - aarch64_special_purpose_registers_data @ - aarch64_general_system_control_registers_data @ - aarch64_debug_registers_data @ - aarch64_performance_monitors_registers_data @ - aarch64_generic_timer_registers_data @ - aarch64_generic_interrupt_controller_CPU_interface_registers_data @ - aarch64_external_debug_registers_data @ - aarch32_general_system_control_registers_data @ - aarch32_debug_registers_data - -let initial_stack_and_reg_data_of_AAarch64_elf_file e_entry all_data_memory = - let (reg_SP_EL0_direction, reg_SP_EL0_width, reg_SP_EL0_initial_index) = - List.assoc "SP_EL0" aarch64_register_data_all in - - (* we compiled a small program that prints out SP and run it a few - times on the Nexus9, these are the results: - 0x0000007fe7f903e0 - 0x0000007fdcdbf3f0 - 0x0000007fcbe1ba90 - 0x0000007fcf378280 - 0x0000007fdd54b8d0 - 0x0000007fd961bc10 - 0x0000007ff3be6350 - 0x0000007fd6bf6ef0 - 0x0000007fff7676f0 - 0x0000007ff2c34560 *) - let initial_SP_EL0 = Nat_big_num.of_string "549739036672" (*"0x0000007fff000000"*) in - let initial_SP_EL0_value = - Sail_impl_base.register_value_of_integer - reg_SP_EL0_width - reg_SP_EL0_initial_index - reg_SP_EL0_direction - initial_SP_EL0 - in - - (* ELF says we need an initial zero doubleword there *) - (* the code actually uses the stack, both above and below, so we map a bit more memory*) - let initial_stack_data = - (* this is a fairly big but arbitrary chunk: *) - (* let initial_stack_data_address = Nat_big_num.sub initial_GPR1_stack_pointer (Nat_big_num.of_int 128) in - [("initial_stack_data", initial_stack_data_address, Lem_list.replicate (128+32) 0 ))] in *) - - [ ("initial_stack_data1", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 16), Lem_list.replicate 8 0); - ("initial_stack_data2", Nat_big_num.sub initial_SP_EL0 (Nat_big_num.of_int 8), Lem_list.replicate 8 0) - ] - in - - let initial_register_abi_data : (string * Sail_impl_base.register_value) list = - [("SP_EL0", initial_SP_EL0_value)] - in - - (initial_stack_data, initial_register_abi_data) -*) let mips_register_data_all = [ (*Pseudo registers*) @@ -749,50 +386,6 @@ let initial_system_state_of_elf_file name = let (isa_defs, isa_memory_access, isa_externs, isa_model, model_reg_d, startaddr, initial_stack_data, initial_register_abi_data, register_data_all) = match Nat_big_num.to_int e_machine with -(* | 21 (* EM_PPC64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_power64.abi_power64_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_PPC_elf_file e_entry !data_mem in - - (Power.defs, - (Power_extras.read_memory_functions,Power_extras.memory_writes,[],[],Power_extras.barrier_functions), - Power_extras.power_externs, - PPC, - D_increasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - ppc_register_data_all) - - | 183 (* EM_AARCH64 *) -> - let startaddr = - let e_entry = Uint64.of_int64 (Nat_big_num.to_int64 e_entry) in - match Abi_aarch64_le.abi_aarch64_le_compute_program_entry_point segments e_entry with - | Error.Fail s -> failwith "Failed computing entry point" - | Error.Success s -> Nat_big_num.of_int64 (Uint64.to_int64 s) - in - - let (initial_stack_data, initial_register_abi_data) = - initial_stack_and_reg_data_of_AAarch64_elf_file e_entry !data_mem in - - (ArmV8.defs, - (ArmV8_extras.aArch64_read_memory_functions, - ArmV8_extras.aArch64_memory_writes, - ArmV8_extras.aArch64_memory_eas, - ArmV8_extras.aArch64_memory_vals, - ArmV8_extras.aArch64_barrier_functions), - [], - AArch64, - D_decreasing, - startaddr, - initial_stack_data, - initial_register_abi_data, - aarch64_register_data_all) *) | 8 (* EM_MIPS *) -> let startaddr = let e_entry = Uint64.of_string (Nat_big_num.to_string e_entry) in @@ -888,52 +481,6 @@ let initial_system_state_of_elf_file name = List.map (fun (name, (binding, fp)) -> (fp, name)) (StringMap.bindings map) in - - (* Now we examine the rest of the data memory, - removing the footprint of the symbols and chunking it into aligned chunks *) - - let rec remove_symbols_from_data_memory data_mem symbols = - match symbols with - | [] -> data_mem - | (name,address,size,bs)::symbols' -> - let data_mem' = - Mem.filter - (fun a v -> - not (Nat_big_num.greater_equal a address && - Nat_big_num.less a (Nat_big_num.add (Nat_big_num.of_int (List.length bs)) address))) - data_mem in - remove_symbols_from_data_memory data_mem' symbols' in - - let trimmed_data_memory : (Nat_big_num.num * memory_byte) list = - Mem.bindings (remove_symbols_from_data_memory !data_mem symbol_table) in - - (* make sure that's ordered increasingly.... *) - let trimmed_data_memory = - List.sort (fun (a,b) (a',b') -> Nat_big_num.compare a a') trimmed_data_memory in - - let aligned a n = (* a mod n = 0 *) - let n_big = Nat_big_num.of_int n in - Nat_big_num.equal (Nat_big_num.modulus a n_big) ((Nat_big_num.of_int 0)) in - - let isplus a' a n = (* a' = a+n *) - Nat_big_num.equal a' (Nat_big_num.add (Nat_big_num.of_int n) a) in - - let rec chunk_data_memory dm = - match dm with - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::(a4,b4)::(a5,b5)::(a6,b6)::(a7,b7)::dm' when - (aligned a0 8 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3 && - isplus a4 a0 4 && isplus a5 a0 5 && isplus a6 a0 6 && isplus a7 a0 7) -> - (a0,8,[b0;b1;b2;b3;b4;b5;b6;b7]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::(a2,b2)::(a3,b3)::dm' when - (aligned a0 4 && isplus a1 a0 1 && isplus a2 a0 2 && isplus a3 a0 3) -> - (a0,4,[b0;b1;b2;b3]) :: chunk_data_memory dm' - | (a0,b0)::(a1,b1)::dm' when - (aligned a0 2 && isplus a1 a0 1) -> - (a0,2,[b0;b1]) :: chunk_data_memory dm' - | (a0,b0)::dm' -> - (a0,1,[b0]):: chunk_data_memory dm' - | [] -> [] in - let initial_register_state = fun rbn -> try @@ -1022,69 +569,10 @@ let stop_condition_met model instr = true | _ -> false) -let is_branch model instruction = - let (name,_,_) = instruction in - match (model , name) with - | (PPC, "B") -> true - | (PPC, "Bc") -> true - | (PPC, "Bclr") -> true - | (PPC, "Bcctr") -> true - | (PPC, _) -> false - | (AArch64, "BranchImmediate") -> true - | (AArch64, "BranchConditional") -> true - | (AArch64, "CompareAndBranch") -> true - | (AArch64, "TestBitAndBranch") -> true - | (AArch64, "BranchRegister") -> true - | (AArch64, _) -> false - | (MIPS, _) -> false (*todo,fill this in*) - let option_int_of_option_integer i = match i with | Some i -> Some (Nat_big_num.to_int i) | None -> None -let set_next_instruction_address model = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let nia_addr = add_address_nat cia_addr 4 in - let nia = register_value_of_address nia_addr Sail_impl_base.D_increasing in - reg := Reg.add "NIA" nia !reg - | _ -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let n_addr = add_address_nat pc_addr 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - reg := Reg.add "_PC" n_pc !reg - | _ -> failwith "_PC address contains unknown or undefined") - | MIPS -> - let pc_addr = address_of_register_value (Reg.find "PC" !reg) in - let branchPending = integer_of_register_value (Reg.find "branchPending" !reg) in - (match (pc_addr, option_int_of_option_integer branchPending) with - | (Some pc_val, Some 0) -> - (* normal -- increment PC *) - let n_addr = add_address_nat pc_val 4 in - let n_pc = register_value_of_address n_addr D_decreasing in - begin - reg := Reg.add "nextPC" n_pc !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inCCallDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - end - | (Some pc_val, Some 1) -> - (* delay slot -- branch to delayed PC and clear branchPending *) - begin - reg := Reg.add "nextPC" (Reg.find "delayedPC" !reg) !reg; - reg := Reg.add "nextPCC" (Reg.find "delayedPCC" !reg) !reg; - reg := Reg.add "branchPending" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing Nat_big_num.zero) !reg; - reg := Reg.add "inBranchDelay" (register_value_of_integer 1 0 Sail_impl_base.D_decreasing (Nat_big_num.of_int 1)) !reg; - end - | (_, _) -> errorf "PC address contains unknown or undefined"; exit 1) - let add1 = Nat_big_num.add (Nat_big_num.of_int 1) let get_addr_trans_regs _ = @@ -1194,68 +682,10 @@ let rec write_events = function | _ -> failwith "Only register write events expected"); write_events events -let fetch_instruction_opcode_and_update_ia model addr_trans = - match model with - | PPC -> - let cia = Reg.find "CIA" !reg in - let cia_addr = address_of_register_value cia in - (match cia_addr with - | Some cia_addr -> - let cia_a = integer_of_address cia_addr in - let opcode = (get_opcode cia_a) in - begin - reg := Reg.add "CIA" (Reg.find "NIA" !reg) !reg; - Opcode opcode - end - | None -> failwith "CIA address contains unknown or undefined") - | AArch64 -> - let pc = Reg.find "_PC" !reg in - let pc_addr = address_of_register_value pc in - (match pc_addr with - | Some pc_addr -> - let pc_a = integer_of_address pc_addr in - let opcode = (get_opcode pc_a) in - Opcode opcode - | None -> failwith "_PC address contains unknown or undefined") - | MIPS -> - begin - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let nextPC = Reg.find "nextPC" !reg in - let pc_addr = address_of_register_value nextPC in - (*let unused = interactf "PC: %s\n" (Printing_functions.register_value_to_string nextPC) in*) - (match pc_addr with - | Some pc_addr -> - let pc_a = match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, Some events -> - write_events (List.rev events); - let nextPC = Reg.find "nextPC" !reg in - reg := Reg.add "PCC" (Reg.find "nextPCC" !reg) !reg; - let pc_addr = address_of_register_value nextPC in - (match pc_addr with - | Some pc_addr -> - (match addr_trans (get_addr_trans_regs ()) pc_addr with - | Some a, Some events -> write_events (List.rev events); integer_of_address a - | Some a, None -> integer_of_address a - | None, _ -> failwith "Address translation failed twice") - | None -> failwith "no nextPc address") - | _ -> failwith "No address and no events from translate address" - in - let opcode = (get_opcode pc_a) in - begin - reg := Reg.add "PC" (Reg.find "nextPC" !reg) !reg; - Opcode opcode - end - | None -> errorf "nextPC contains unknown or undefined"; exit 1) - end - | _ -> assert false - let get_pc_address = function | MIPS -> Reg.find "PC" !reg | PPC -> Reg.find "CIA" !reg | AArch64 -> Reg.find "_PC" !reg - let option_int_of_reg str = option_int_of_option_integer (integer_of_register_value (Reg.find str !reg)) -- cgit v1.2.3 From 4de5d52ee0f525d7c472e8aa3ee2a8158d888148 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 27 Nov 2017 17:30:03 +0000 Subject: Split rewriter into separate rewriting library and rewrite passes As discussed previously, we wanted to start refactoring the re-writer to make it a bit less monolithic, and in the future potentially break it into separate files for backend-specific rewrites and stuff. - rewriter.ml now contains the generic re-writing code - rewrites.ml contains the rewriting passes themselves It would be nice if the generic rewriting code didn't depend on the typechecker, because then it could be used in ASL parser on untyped code. --- src/ast_util.ml | 2 + src/ast_util.mli | 1 + src/ocaml_backend.ml | 6 +- src/process_file.ml | 8 +- src/rewriter.ml | 2871 +------------------------------------------------- src/rewriter.mli | 43 +- src/rewrites.ml | 2767 ++++++++++++++++++++++++++++++++++++++++++++++++ src/rewrites.mli | 60 ++ 8 files changed, 2885 insertions(+), 2873 deletions(-) create mode 100644 src/rewrites.ml create mode 100644 src/rewrites.mli (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index d26e12ed..b9e03987 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -48,6 +48,8 @@ open Big_int let no_annot = (Parse_ast.Unknown, ()) +let gen_loc l = Parse_ast.Generated l + let inc_ord = Ord_aux (Ord_inc, Parse_ast.Unknown) let dec_ord = Ord_aux (Ord_dec, Parse_ast.Unknown) diff --git a/src/ast_util.mli b/src/ast_util.mli index 2059bb7f..66d87c71 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -46,6 +46,7 @@ open Ast open Big_int val no_annot : unit annot +val gen_loc : Parse_ast.l -> Parse_ast.l val mk_id : string -> id val mk_kid : string -> kid diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index bf5ce83c..333505e0 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -197,7 +197,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = ^/^ ocaml_exp ctx exp | E_internal_let (lexp, exp1, exp2) -> separate space [string "let"; ocaml_atomic_lexp ctx lexp; - equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewriter.simple_typ (typ_of exp1))); string "in"] + equals; string "ref"; parens (ocaml_atomic_exp ctx exp1 ^^ space ^^ colon ^^ space ^^ ocaml_typ ctx (Rewrites.simple_typ (typ_of exp1))); string "in"] ^/^ ocaml_exp ctx exp2 | E_loop (Until, cond, body) -> let loop_body = @@ -274,7 +274,7 @@ and ocaml_atomic_exp ctx (E_aux (exp_aux, _) as exp) = | Register typ -> if !opt_trace_ocaml then let var = gensym () in - let str_typ = parens (ocaml_string_typ (Rewriter.simple_typ typ) var) in + let str_typ = parens (ocaml_string_typ (Rewrites.simple_typ typ) var) in parens (separate space [string "let"; var; equals; bang ^^ zencode ctx id; string "in"; string "trace_read" ^^ space ^^ string_lit (string_of_id id) ^^ space ^^ str_typ ^^ semi; var]) else bang ^^ zencode ctx id @@ -293,7 +293,7 @@ and ocaml_assignment ctx (LEXP_aux (lexp_aux, _) as lexp) exp = let traced_exp = if !opt_trace_ocaml then let var = gensym () in - let str_typ = parens (ocaml_string_typ (Rewriter.simple_typ typ) var) in + let str_typ = parens (ocaml_string_typ (Rewrites.simple_typ typ) var) in parens (separate space [string "let"; var; equals; ocaml_atomic_exp ctx exp; string "in"; string "trace_write" ^^ space ^^ string_lit (string_of_id id) ^^ space ^^ str_typ ^^ semi; var]) else ocaml_atomic_exp ctx exp diff --git a/src/process_file.ml b/src/process_file.ml index 344e5951..e4518837 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -226,7 +226,7 @@ let rewrite rewriters defs = exit 1 let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] -let rewrite_undefined = rewrite [("undefined", fun x -> Rewriter.rewrite_undefined !opt_lem_mwords x)] -let rewrite_ast_lem = rewrite Rewriter.rewrite_defs_lem -let rewrite_ast_ocaml = rewrite Rewriter.rewrite_defs_ocaml -let rewrite_ast_check = rewrite Rewriter.rewrite_defs_check +let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !opt_lem_mwords x)] +let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem +let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/rewriter.ml b/src/rewriter.ml index fd1479a7..c483cf9b 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -58,8 +58,6 @@ type 'a rewriters = { } -let (>>) f g = fun x -> g(f(x)) - let effect_of_fpat (FP_aux (_,(_,a))) = effect_of_annot a let effect_of_lexp (LEXP_aux (_,(_,a))) = effect_of_annot a let effect_of_fexp (FE_aux (_,(_,a))) = effect_of_annot a @@ -75,19 +73,7 @@ let effect_of_pexp (Pat_aux (pexp,(_,a))) = match a with | Pat_when (_, g, e) -> union_effects (effect_of g) (effect_of e)) let effect_of_lb (LB_aux (_,(_,a))) = effect_of_annot a -let get_loc_exp (E_aux (_,(l,_))) = l -let gen_loc l = Parse_ast.Generated l - let simple_annot l typ = (gen_loc l, Some (Env.empty, typ, no_effect)) -let simple_num l n = E_aux ( - E_lit (L_aux (L_num n, gen_loc l)), - simple_annot (gen_loc l) - (atom_typ (Nexp_aux (Nexp_constant n, gen_loc l)))) -let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, Some (env, typ, effect))) -let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect -let annot_pat p_aux l env typ = P_aux (p_aux, (l, Some (env, typ, no_effect))) -let annot_letbind (p_aux, exp) l env typ = - LB_aux (LB_val (annot_pat p_aux l env typ, exp), (l, Some (env, typ, effect_of exp))) let rec small (E_aux (exp,_)) = match exp with | E_id _ @@ -98,27 +84,6 @@ let rec small (E_aux (exp,_)) = match exp with | E_sizeof _ -> true | _ -> false -let fresh_name_counter = ref 0 - -let fresh_name () = - let current = !fresh_name_counter in - let () = fresh_name_counter := (current + 1) in - current -let reset_fresh_name_counter () = - fresh_name_counter := 0 - -let fresh_id pre l = - let current = fresh_name () in - Id_aux (Id (pre ^ string_of_int current), gen_loc l) - -let fresh_id_exp pre ((l,annot)) = - let id = fresh_id pre l in - E_aux (E_id id, (gen_loc l, annot)) - -let fresh_id_pat pre ((l,annot)) = - let id = fresh_id pre l in - P_aux (P_id id, (gen_loc l, annot)) - let union_eff_exps es = List.fold_left union_effects no_effect (List.map effect_of es) @@ -258,78 +223,10 @@ let updates_vars_effs = function let updates_vars eaux = updates_vars_effs (effect_of eaux) -let id_to_string (Id_aux(id,l)) = - match id with - | Id(s) -> s - | DeIid(s) -> s - - -(*let rec partial_assoc (eq: 'a -> 'a -> bool) (v: 'a) (ls : ('a *'b) list ) : 'b option = match ls with - | [] -> None - | (v1,v2)::ls -> if (eq v1 v) then Some v2 else partial_assoc eq v ls - -let mk_atom_typ i = {t=Tapp("atom",[TA_nexp i])} - -let simple_num l n : tannot exp = - let typ = simple_annot (mk_atom_typ (mk_c (big_int_of_int n))) in - E_aux (E_lit (L_aux (L_num n,l)), (l,typ)) - -let rec rewrite_nexp_to_exp program_vars l nexp = - let rewrite n = rewrite_nexp_to_exp program_vars l n in - let typ = mk_atom_typ nexp in - let actual_rewrite_n nexp = - match nexp.nexp with - | Nconst i -> E_aux (E_lit (L_aux (L_num (int_of_big_int i),l)), (l,simple_annot typ)) - | Nadd (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "+",l)),rewrite n2), - (l, (tag_annot typ (External (Some "add"))))) - | Nmult (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "*",l)),rewrite n2), - (l, tag_annot typ (External (Some "multiply")))) - | Nsub (n1,n2) -> E_aux (E_app_infix (rewrite n1,(Id_aux (Id "-",l)),rewrite n2), - (l, tag_annot typ (External (Some "minus")))) - | N2n (n, _) -> E_aux (E_app_infix (E_aux (E_lit (L_aux (L_num 2,l)), (l, simple_annot (mk_atom_typ n_two))), - (Id_aux (Id "**",l)), - rewrite n), (l, tag_annot typ (External (Some "power")))) - | Npow(n,i) -> E_aux (E_app_infix - (rewrite n, (Id_aux (Id "**",l)), - E_aux (E_lit (L_aux (L_num i,l)), - (l, simple_annot (mk_atom_typ (mk_c_int i))))), - (l, tag_annot typ (External (Some "power")))) - | Nneg(n) -> E_aux (E_app_infix (E_aux (E_lit (L_aux (L_num 0,l)), (l, simple_annot (mk_atom_typ n_zero))), - (Id_aux (Id "-",l)), - rewrite n), - (l, tag_annot typ (External (Some "minus")))) - | Nvar v -> (*TODO these need to generate an error as it's a place where there's insufficient specification. - But, for now I need to permit this to make power.sail compile, and most errors are in trap - or vectors *) - (*let _ = Printf.eprintf "unbound variable here %s\n" v in*) - E_aux (E_id (Id_aux (Id v,l)),(l,simple_annot typ)) - | _ -> raise (Reporting_basic.err_unreachable l ("rewrite_nexp given n that can't be rewritten: " ^ (n_to_string nexp))) in - match program_vars with - | None -> actual_rewrite_n nexp - | Some program_vars -> - (match partial_assoc nexp_eq_check nexp program_vars with - | None -> actual_rewrite_n nexp - | Some(None,ev) -> - (*let _ = Printf.eprintf "var case of rewrite, %s\n" ev in*) - E_aux (E_id (Id_aux (Id ev,l)), (l, simple_annot typ)) - | Some(Some f,ev) -> - E_aux (E_app ((Id_aux (Id f,l)), [ (E_aux (E_id (Id_aux (Id ev,l)), (l,simple_annot typ)))]), - (l, tag_annot typ (External (Some f))))) - -let rec match_to_program_vars ns bounds = - match ns with - | [] -> [] - | n::ns -> match find_var_from_nexp n bounds with - | None -> match_to_program_vars ns bounds - | Some(augment,ev) -> - (*let _ = Printf.eprintf "adding n %s to program var %s\n" (n_to_string n) ev in*) - (n,(augment,ev))::(match_to_program_vars ns bounds)*) - let explode s = let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in exp (String.length s - 1) [] - let vector_string_to_bit_list l lit = let hexchar_to_binlist = function @@ -350,14 +247,14 @@ let vector_string_to_bit_list l lit = | 'E' -> ['1';'1';'1';'0'] | 'F' -> ['1';'1';'1';'1'] | _ -> raise (Reporting_basic.err_unreachable l "hexchar_to_binlist given unrecognized character") in - + let s_bin = match lit with | L_hex s_hex -> List.flatten (List.map hexchar_to_binlist (explode (String.uppercase s_hex))) | L_bin s_bin -> explode s_bin | _ -> raise (Reporting_basic.err_unreachable l "s_bin given non vector literal") in List.map (function '0' -> L_aux (L_zero, gen_loc l) - | '1' -> L_aux (L_one,gen_loc l) + | '1' -> L_aux (L_one, gen_loc l) | _ -> raise (Reporting_basic.err_unreachable (gen_loc l) "binary had non-zero or one")) s_bin let rewrite_pat rewriters (P_aux (pat,(l,annot))) = @@ -381,7 +278,7 @@ let rewrite_pat rewriters (P_aux (pat,(l,annot))) = | P_list pats -> rewrap (P_list (List.map rewrite pats)) | P_cons (pat1, pat2) -> rewrap (P_cons (rewrite pat1, rewrite pat2)) -let rewrite_exp rewriters (E_aux (exp,(l,annot))) = +let rewrite_exp rewriters (E_aux (exp,(l,annot))) = let rewrap e = E_aux (e,(l,annot)) in let rewrite = rewriters.rewrite_exp rewriters in match exp with @@ -406,22 +303,22 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot))) = | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite vec,rewrite index)) | E_vector_subrange (vec,i1,i2) -> rewrap (E_vector_subrange (rewrite vec,rewrite i1,rewrite i2)) - | E_vector_update (vec,index,new_v) -> + | E_vector_update (vec,index,new_v) -> rewrap (E_vector_update (rewrite vec,rewrite index,rewrite new_v)) | E_vector_update_subrange (vec,i1,i2,new_v) -> rewrap (E_vector_update_subrange (rewrite vec,rewrite i1,rewrite i2,rewrite new_v)) | E_vector_append (v1,v2) -> rewrap (E_vector_append (rewrite v1,rewrite v2)) - | E_list exps -> rewrap (E_list (List.map rewrite exps)) + | E_list exps -> rewrap (E_list (List.map rewrite exps)) | E_cons(h,t) -> rewrap (E_cons (rewrite h,rewrite t)) - | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> - rewrap (E_record - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + | E_record (FES_aux (FES_Fexps(fexps, bool),fannot)) -> + rewrap (E_record + (FES_aux (FES_Fexps + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot))) | E_record_update (re,(FES_aux (FES_Fexps(fexps, bool),fannot))) -> rewrap (E_record_update ((rewrite re), - (FES_aux (FES_Fexps - (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> + (FES_aux (FES_Fexps + (List.map (fun (FE_aux(FE_Fexp(id,e),fannot)) -> FE_aux(FE_Fexp(id,rewrite e),fannot)) fexps, bool), fannot)))) | E_field(exp,id) -> rewrap (E_field(rewrite exp,id)) | E_case (exp,pexps) -> @@ -439,102 +336,6 @@ let rewrite_exp rewriters (E_aux (exp,(l,annot))) = | E_assert(e1,e2) -> rewrap (E_assert(rewrite e1,rewrite e2)) | E_internal_cast (casted_annot,exp) -> rewrap (E_internal_cast (casted_annot, rewrite exp)) - (* check_exp (env_of exp) (strip_exp exp) (typ_of_annot casted_annot) *) - (*let new_exp = rewrite exp in - (*let _ = Printf.eprintf "Removing an internal_cast with %s\n" (tannot_to_string casted_annot) in*) - (match casted_annot,exp with - | Base((_,t),_,_,_,_,_),E_aux(ec,(ecl,Base((_,exp_t),_,_,_,_,_))) -> - (*let _ = Printf.eprintf "Considering removing an internal cast where the two types are %s and %s\n" - (t_to_string t) (t_to_string exp_t) in*) - (match t.t,exp_t.t with - (*TODO should pass d_env into here so that I can look at the abbreviations if there are any here*) - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]), - Tapp("vector",[TA_nexp n2;TA_nexp nw2;TA_ord o2;_]) - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]), - Tapp("reg",[TA_typ {t=(Tapp("vector",[TA_nexp n2; TA_nexp nw2; TA_ord o2;_]))}]) -> - (match n1.nexp with - | Nconst i1 -> if nexp_eq n1 n2 then new_exp else rewrap (E_cast (t_to_typ t,new_exp)) - | _ -> (match o1.order with - | Odec -> - (*let _ = Printf.eprintf "Considering removing a cast or not: %s %s, %b\n" - (n_to_string nw1) (n_to_string n1) (nexp_one_more_than nw1 n1) in*) - rewrap (E_cast (Typ_aux (Typ_var (Kid_aux((Var "length"),Parse_ast.Generated l)), - Parse_ast.Generated l),new_exp)) - | _ -> new_exp)) - | _ -> new_exp - | Base((_,t),_,_,_,_,_),_ -> - (*let _ = Printf.eprintf "Considering removing an internal cast where the remaining type is %s\n%!" - (t_to_string t) in*) - (match t.t with - | Tapp("vector",[TA_nexp n1;TA_nexp nw1;TA_ord o1;_]) -> - (match o1.order with - | Odec -> - let _ = Printf.eprintf "Considering removing a cast or not: %s %s, %b\n" - (n_to_string nw1) (n_to_string n1) (nexp_one_more_than nw1 n1) in - rewrap (E_cast (Typ_aux (Typ_var (Kid_aux((Var "length"), Parse_ast.Generated l)), - Parse_ast.Generated l), new_exp)) - | _ -> new_exp) - | _ -> new_exp) - | _ -> (*let _ = Printf.eprintf "Not a base match?\n" in*) new_exp*) - (*| E_internal_exp (l,impl) -> - match impl with - | Base((_,t),_,_,_,_,bounds) -> - (*let _ = Printf.eprintf "Rewriting internal expression, with type %s, and bounds %s\n" - (t_to_string t) (bounds_to_string bounds) in*) - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (*let _ = Printf.eprintf "Bounds after looking at nmap %s\n" (bounds_to_string bounds) in*) - (match t.t with - (*Old case; should possibly be removed*) - | Tapp("register",[TA_typ {t= Tapp("vector",[ _; TA_nexp r;_;_])}]) - | Tapp("vector", [_;TA_nexp r;_;_]) - | Tabbrev(_, {t=Tapp("vector",[_;TA_nexp r;_;_])}) -> - (*let _ = Printf.eprintf "vector case with %s, bounds are %s\n" - (n_to_string r) (bounds_to_string bounds) in*) - let nexps = expand_nexp r in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l r - | map -> rewrite_nexp_to_exp (Some map) l r) - | Tapp("implicit", [TA_nexp i]) -> - (*let _ = Printf.eprintf "Implicit case with %s\n" (n_to_string i) in*) - let nexps = expand_nexp i in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l i - | map -> rewrite_nexp_to_exp (Some map) l i) - | _ -> - raise (Reporting_basic.err_unreachable l - ("Internal_exp given unexpected types " ^ (t_to_string t)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp given none Base annot"))*) - (*| E_sizeof_internal (l,impl) -> - (match impl with - | Base((_,t),_,_,_,_,bounds) -> - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (match t.t with - | Tapp("atom",[TA_nexp n]) -> - let nexps = expand_nexp n in - (*let _ = Printf.eprintf "Removing sizeof_internal with type %s\n" (t_to_string t) in*) - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l n - | map -> rewrite_nexp_to_exp (Some map) l n) - | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had non-atom type " ^ (t_to_string t)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Sizeof internal had none base annot"))*) - (*| E_internal_exp_user ((l,user_spec),(_,impl)) -> - (match (user_spec,impl) with - | (Base((_,tu),_,_,_,_,_), Base((_,ti),_,_,_,_,bounds)) -> - (*let _ = Printf.eprintf "E_interal_user getting rewritten two types are %s and %s\n" - (t_to_string tu) (t_to_string ti) in*) - let bounds = match nmap with | None -> bounds | Some (nm,_) -> add_map_to_bounds nm bounds in - (match (tu.t,ti.t) with - | (Tapp("implicit", [TA_nexp u]),Tapp("implicit",[TA_nexp i])) -> - (*let _ = Printf.eprintf "Implicit case with %s\n" (n_to_string i) in*) - let nexps = expand_nexp i in - (match (match_to_program_vars nexps bounds) with - | [] -> rewrite_nexp_to_exp None l i - (*add u to program_vars env; for now it will work out properly by accident*) - | map -> rewrite_nexp_to_exp (Some map) l i) - | _ -> - raise (Reporting_basic.err_unreachable l - ("Internal_exp_user given unexpected types " ^ (t_to_string tu) ^ ", " ^ (t_to_string ti)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Internal_exp_user given none Base annot")))*) | E_internal_let _ -> raise (Reporting_basic.err_unreachable l "Internal let found before it should have been introduced") | E_internal_return _ -> raise (Reporting_basic.err_unreachable l "Internal return found before it should have been introduced") | E_internal_plet _ -> raise (Reporting_basic.err_unreachable l " Internal plet found before it should have been introduced") @@ -563,7 +364,6 @@ let rewrite_lexp rewriters (LEXP_aux(lexp,(l,annot))) = let rewrite_fun rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = - let _ = reset_fresh_name_counter () in (FCL_aux (FCL_Funcl (id,rewriters.rewrite_pat rewriters pat, rewriters.rewrite_exp rewriters exp),(l,annot))) in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) @@ -589,7 +389,7 @@ let rewriters_base = rewrite_fun = rewrite_fun; rewrite_def = rewrite_def; rewrite_defs = rewrite_defs_base} - + let rewrite_defs (Defs defs) = rewrite_defs_base rewriters_base (Defs defs) module Envmap = Finite_map.Fmap_map(String) @@ -986,2650 +786,3 @@ let compute_exp_alg bot join = ; lB_aux = (fun ((vl,lb),annot) -> (vl,LB_aux (lb,annot))) ; pat_alg = compute_pat_alg bot join } - -let rec rewrite_nexp_ids env (Nexp_aux (nexp, l) as nexp_aux) = match nexp with -| Nexp_id id -> rewrite_nexp_ids env (Env.get_num_def id env) -| Nexp_times (nexp1, nexp2) -> Nexp_aux (Nexp_times (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) -| Nexp_sum (nexp1, nexp2) -> Nexp_aux (Nexp_sum (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) -| Nexp_minus (nexp1, nexp2) -> Nexp_aux (Nexp_minus (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) -| Nexp_exp nexp -> Nexp_aux (Nexp_exp (rewrite_nexp_ids env nexp), l) -| Nexp_neg nexp -> Nexp_aux (Nexp_neg (rewrite_nexp_ids env nexp), l) -| _ -> nexp_aux - -let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = - let rec rewrite_typ env (Typ_aux (typ, l) as typ_aux) = match typ with - | Typ_fn (arg_t, ret_t, eff) -> - Typ_aux (Typ_fn (rewrite_typ env arg_t, rewrite_typ env ret_t, eff), l) - | Typ_tup ts -> - Typ_aux (Typ_tup (List.map (rewrite_typ env) ts), l) - | Typ_exist (kids, c, typ) -> - Typ_aux (Typ_exist (kids, c, rewrite_typ env typ), l) - | Typ_app (id, targs) -> - Typ_aux (Typ_app (id, List.map (rewrite_typ_arg env) targs), l) - | _ -> typ_aux - and rewrite_typ_arg env (Typ_arg_aux (targ, l) as targ_aux) = match targ with - | Typ_arg_nexp nexp -> - Typ_arg_aux (Typ_arg_nexp (rewrite_nexp_ids env nexp), l) - | Typ_arg_typ typ -> - Typ_arg_aux (Typ_arg_typ (rewrite_typ env typ), l) - | Typ_arg_order ord -> - Typ_arg_aux (Typ_arg_order ord, l) - in - - let rewrite_annot = function - | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_typ env typ, eff)) - | (l, None) -> (l, None) - in - - rewrite_defs_base { - rewriters_base with rewrite_exp = (fun _ -> map_exp_annot rewrite_annot) - }, - rewrite_typ - - -(* Re-write trivial sizeof expressions - trivial meaning that the - value of the sizeof can be directly inferred from the type - variables in scope. *) -let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = - let extract_typ_var l env nexp (id, (_, typ)) = - let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in - match destruct_atom_nexp env typ with - | Some size when prove env (nc_eq size nexp) -> Some var - | _ -> - begin - match destruct_vector env typ with - | Some (_, len, _, _) when prove env (nc_eq len nexp) -> - Some (E_aux (E_app (mk_id "length", [var]), (l, Some (env, atom_typ len, no_effect)))) - | _ -> None - end - in - let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = - match nexp_aux with - | Nexp_sum (n1, n2) -> - mk_exp (E_app (mk_id "add_range", [split_nexp n1; split_nexp n2])) - | Nexp_minus (n1, n2) -> - mk_exp (E_app (mk_id "sub_range", [split_nexp n1; split_nexp n2])) - | Nexp_times (n1, n2) -> - mk_exp (E_app (mk_id "mult_range", [split_nexp n1; split_nexp n2])) - | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_range", [split_nexp nexp])) - | _ -> mk_exp (E_sizeof nexp) - in - let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = - let env = env_of orig_exp in - match e_aux with - | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) -> - E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) - | E_sizeof nexp -> - begin - match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with - | Nexp_aux (Nexp_constant c, _) -> - E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) - | _ -> - let locals = Env.get_locals env in - let exps = Bindings.bindings locals - |> List.map (extract_typ_var l env nexp) - |> List.map (fun opt -> match opt with Some x -> [x] | None -> []) - |> List.concat - in - match exps with - | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp) - | [] when split_sizeof -> - fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp)) - | [] -> orig_exp - end - | _ -> orig_exp - and rewrite_e_sizeof split_sizeof = - { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) } - in - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true - -(* Rewrite sizeof expressions with type-level variables to - term-level expressions - - For each type-level variable used in a sizeof expressions whose value cannot - be directly extracted from existing parameters of the surrounding function, - a further parameter is added; calls to the function are rewritten - accordingly (possibly causing further rewriting in the calling function) *) -let rewrite_sizeof (Defs defs) = - let sizeof_frees exp = - fst (fold_exp - { (compute_exp_alg KidSet.empty KidSet.union) with - e_sizeof = (fun nexp -> (nexp_frees nexp, E_sizeof nexp)) } - exp) in - - (* Collect nexps whose values can be obtained directly from a pattern bind *) - let nexps_from_params pat = - fst (fold_pat - { (compute_pat_alg [] (@)) with - p_aux = (fun ((v,pat),((l,_) as annot)) -> - let v' = match pat with - | P_id id | P_as (_, id) -> - let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in - (match typ with - | Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) - when string_of_id atom = "atom" -> - [nexp, E_id id] - | Typ_app (vector, _) when string_of_id vector = "vector" -> - let id_length = Id_aux (Id "length", gen_loc l) in - (try - (match Env.get_val_spec id_length (env_of_annot annot) with - | _ -> - let (_,len,_,_) = vector_typ_args_of typ_aux in - let exp = E_app (id_length, [E_aux (E_id id, annot)]) in - [len, exp]) - with - | _ -> []) - | _ -> []) - | _ -> [] in - (v @ v', P_aux (pat,annot)))} pat) in - - (* Substitute collected values in sizeof expressions *) - let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) = - try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap) - with - | Not_found -> - let binop nexp1 op nexp2 = E_app_infix ( - E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)), - Id_aux (Id op, Parse_ast.Unknown), - E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2)) - ) in - let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in - (match nexp with - | Nexp_constant i -> E_lit (L_aux (L_num i, l)) - | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2 - | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2 - | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2 - | _ -> E_sizeof nexp_aux) in - - let ex_regex = Str.regexp "'ex[0-9]+" in - - (* Rewrite calls to functions which have had parameters added to pass values - of type-level variables; these are added as sizeof expressions first, and - then further rewritten as above. *) - let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) = - let env = env_of_annot annot in - let full_exp = E_aux (exp, annot) in - let orig_exp = E_aux (exp_orig, annot) in - match exp with - | E_app (f, args) -> - if Bindings.mem f param_map then - (* Retrieve instantiation of the type variables of the called function - for the given parameters in the original environment *) - let inst = - try instantiation_of orig_exp with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err)) in - (* Rewrite the inst using orig_kid so that each type variable has it's - original name rather than a mangled typechecker name *) - let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in - let kid_exp kid = begin - (* We really don't want to see an existential here! *) - assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); - let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in - match uvar with - | Some (U_nexp nexp) -> - let sizeof = E_aux (E_sizeof nexp, (l, Some (env, atom_typ nexp, no_effect))) in - (try rewrite_trivial_sizeof_exp sizeof with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err))) - (* If the type variable is Not_found then it was probably - introduced by a P_var pattern, so it likely exists as - a variable in scope. It can't be an existential because the assert rules that out. *) - | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) - | _ -> - raise (Reporting_basic.err_unreachable l - ("failed to infer nexp for type variable " ^ string_of_kid kid ^ - " of function " ^ string_of_id f)) - end in - let kid_exps = List.map kid_exp (KidSet.elements (Bindings.find f param_map)) in - (E_aux (E_app (f, kid_exps @ args), annot), orig_exp) - else (full_exp, orig_exp) - | _ -> (full_exp, orig_exp) in - - (* Plug this into a folding algorithm that also keeps around a copy of the - original expressions, which we use to infer instantiations of type variables - in the original environments *) - let copy_exp_alg = - { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) - ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) - ; e_id = (fun id -> (E_id id, E_id id)) - ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) - ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) - ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) - ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2'))) - ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es')) - ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3'))) - ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4'))) - ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2'))) - ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es')) - ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2'))) - ; e_vector_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3'))) - ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3'))) - ; e_vector_update_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4'))) - ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) - ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) - ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) - ; e_record = (fun (fexps, fexps') -> (E_record fexps, E_record fexps')) - ; e_record_update = (fun ((e1,e1'),(fexp,fexp')) -> (E_record_update (e1,fexp), E_record_update (e1',fexp'))) - ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) - ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) - ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2'))) - ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2'))) - ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) - ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) - ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) - ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) - ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) - ; e_internal_cast = (fun (a,(e1,e1')) -> (E_internal_cast (a,e1), E_internal_cast (a,e1'))) - ; e_internal_exp = (fun a -> (E_internal_exp a, E_internal_exp a)) - ; e_internal_exp_user = (fun (a1,a2) -> (E_internal_exp_user (a1,a2), E_internal_exp_user (a1,a2))) - ; e_comment = (fun c -> (E_comment c, E_comment c)) - ; e_comment_struc = (fun (e,e') -> (E_comment_struc e, E_comment_struc e')) - ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_internal_let (lexp,e2,e3), E_internal_let (lexp',e2',e3'))) - ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) - ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) - ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) - ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) - ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) - ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) - ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) - ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2'))) - ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3'))) - ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id))) - ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) - ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) - ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) - ; fES_Fexps = (fun (fexps,b) -> let (fexps, fexps') = List.split fexps in (FES_Fexps (fexps,b), FES_Fexps (fexps',b))) - ; fES_aux = (fun ((fexp,fexp'),annot) -> (FES_aux (fexp,annot), FES_aux (fexp',annot))) - ; def_val_empty = (Def_val_empty, Def_val_empty) - ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) - ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) - ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e'))) - ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2'))) - ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a))) - ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e'))) - ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot))) - ; pat_alg = id_pat_alg - } in - - let rewrite_sizeof_fun params_map - (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) = - let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,pat,exp), annot)) (funcls,nvars) = - let body_env = env_of exp in - let body_typ = typ_of exp in - let nmap = nexps_from_params pat in - (* first rewrite calls to other functions... *) - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - (* ... then rewrite sizeof expressions in current function body *) - let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in - (FCL_aux (FCL_Funcl (id,pat,exp''), annot) :: funcls, - KidSet.union nvars (sizeof_frees exp'')) in - let (funcls, nvars) = List.fold_right rewrite_funcl_body funcls ([], KidSet.empty) in - (* Add a parameter for each remaining free type-level variable in a - sizeof expression *) - let kid_typ kid = atom_typ (nvar kid) in - let kid_annot kid = simple_annot l (kid_typ kid) in - let kid_pat kid = - P_aux (P_typ (kid_typ kid, - P_aux (P_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)), - kid_annot kid)), kid_annot kid) in - let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in - let kid_typs = List.map kid_typ (KidSet.elements nvars) in - let kid_pats = List.map kid_pat (KidSet.elements nvars) in - let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in - let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pat, exp), annot) as funcl) = - let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) = - let penv = env_of_annot pannot in - let peff = effect_of_annot (snd pannot) in - if KidSet.is_empty nvars then paux else - match pat_typ_of paux with - | Typ_aux (Typ_tup typs, _) -> - let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in - (match pat with - | P_tup pats -> - P_aux (P_tup (kid_pats @ pats), (l, Some (penv, ptyp', peff))) - | P_wild -> P_aux (pat, (l, Some (penv, ptyp', peff))) - | P_typ (Typ_aux (Typ_tup typs, l), pat) -> - P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l), - rewrite_pat pat), (l, Some (penv, ptyp', peff))) - | P_as (_, id) | P_id id -> - (* adding parameters here would change the type of id; - we should remove the P_as/P_id here and add a let-binding to the body *) - raise (Reporting_basic.err_todo l - "rewriting as- or id-patterns for sizeof expressions not yet implemented") - | _ -> - raise (Reporting_basic.err_unreachable l - "unexpected pattern while rewriting function parameters for sizeof expressions")) - | ptyp -> - let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in - P_aux (P_tup (kid_pats @ [paux]), (l, Some (penv, ptyp', peff))) in - let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in - FCL_aux (FCL_Funcl (id, rewrite_pat pat, exp'), annot) in - let funcls = List.map rewrite_funcl_params funcls in - (nvars, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in - - let rewrite_sizeof_def (params_map, defs) = function - | DEF_fundef fd as def -> - let (nvars, fd') = rewrite_sizeof_fun params_map fd in - let id = id_of_fundef fd in - let params_map' = - if KidSet.is_empty nvars then params_map - else Bindings.add id nvars params_map in - (params_map', defs @ [DEF_fundef fd']) - | DEF_val (LB_aux (lb, annot)) -> - begin - let lb' = match lb with - | LB_val (pat, exp) -> - let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in - LB_val (pat, exp') in - (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) - end - | def -> - (params_map, defs @ [def]) in - - let rewrite_sizeof_valspec params_map def = - let rewrite_typschm (TypSchm_aux (TypSchm_ts (tq, typ), l) as ts) id = - if Bindings.mem id params_map then - let kid_typs = List.map (fun kid -> atom_typ (nvar kid)) - (KidSet.elements (Bindings.find id params_map)) in - let typ' = match typ with - | Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) -> - let vtyp_arg' = begin - match vtyp_arg with - | Typ_aux (Typ_tup typs, vl) -> - Typ_aux (Typ_tup (kid_typs @ typs), vl) - | _ -> Typ_aux (Typ_tup (kid_typs @ [vtyp_arg]), vl) - end in - Typ_aux (Typ_fn (vtyp_arg', vtyp_ret, declared_eff), vl) - | _ -> - raise (Reporting_basic.err_typ l "val spec with non-function type") in - TypSchm_aux (TypSchm_ts (tq, typ'), l) - else ts in - match def with - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext, is_cast), a)) -> - DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a)) - | def -> def - in - - let (params_map, defs) = List.fold_left rewrite_sizeof_def - (Bindings.empty, []) defs in - let defs = List.map (rewrite_sizeof_valspec params_map) defs in - Defs defs - (* FIXME: Won't re-check due to flow typing and E_constraint re-write before E_sizeof re-write. - Requires the typechecker to be more smart about different representations for valid flow typing constraints. - fst (check initial_env (Defs defs)) - *) - -let remove_vector_concat_pat pat = - - (* ivc: bool that indicates whether the exp is in a vector_concat pattern *) - let remove_typed_patterns = - fold_pat { id_pat_alg with - p_aux = (function - | (P_typ (_,P_aux (p,_)),annot) - | (p,annot) -> - P_aux (p,annot) - ) - } in - - (* let pat = remove_typed_patterns pat in *) - - let fresh_id_v = fresh_id "v__" in - - (* expects that P_typ elements have been removed from AST, - that the length of all vectors involved is known, - that we don't have indexed vectors *) - - (* introduce names for all patterns of form P_vector_concat *) - let name_vector_concat_roots = - { p_lit = (fun lit -> P_lit lit) - ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) (* cannot happen *) - ; p_wild = P_wild - ; p_as = (fun (pat,id) -> P_as (pat true,id)) - ; p_id = (fun id -> P_id id) - ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) - ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) - ; p_record = (fun (fpats,b) -> P_record (fpats, b)) - ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) - ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) - ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) - ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) - ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) - ; p_aux = - (fun (pat,((l,_) as annot)) contained_in_p_as -> - match pat with - | P_vector_concat pats -> - (if contained_in_p_as - then P_aux (pat,annot) - else P_aux (P_as (P_aux (pat,annot),fresh_id_v l),annot)) - | _ -> P_aux (pat,annot) - ) - ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) - ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) - } in - - let pat = (fold_pat name_vector_concat_roots pat) false in - - (* introduce names for all unnamed child nodes of P_vector_concat *) - let name_vector_concat_elements = - let p_vector_concat pats = - let rec aux ((P_aux (p,((l,_) as a))) as pat) = match p with - | P_vector _ -> P_aux (P_as (pat,fresh_id_v l),a) - | P_id id -> P_aux (P_id id,a) - | P_as (p,id) -> P_aux (P_as (p,id),a) - | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) - | P_wild -> P_aux (P_wild,a) - | _ -> - raise - (Reporting_basic.err_unreachable - l "name_vector_concat_elements: Non-vector in vector-concat pattern") in - P_vector_concat (List.map aux pats) in - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat name_vector_concat_elements pat in - - - - let rec tag_last = function - | x :: xs -> let is_last = xs = [] in (x,is_last) :: tag_last xs - | _ -> [] in - - (* remove names from vectors in vector_concat patterns and collect them as declarations for the - function body or expression *) - let unname_vector_concat_elements = (* : - ('a, - 'a pat * ((tannot exp -> tannot exp) list), - 'a pat_aux * ((tannot exp -> tannot exp) list), - 'a fpat * ((tannot exp -> tannot exp) list), - 'a fpat_aux * ((tannot exp -> tannot exp) list)) - pat_alg = *) - - (* build a let-expression of the form "let child = root[i..j] in body" *) - let letbind_vec typ_opt (rootid,rannot) (child,cannot) (i,j) = - let (l,_) = cannot in - let env = env_of_annot rannot in - let rootname = string_of_id rootid in - let childname = string_of_id child in - - let root = E_aux (E_id rootid, rannot) in - let index_i = simple_num l i in - let index_j = simple_num l j in - - (* FIXME *) - let subv = fix_eff_exp (E_aux (E_vector_subrange (root, index_i, index_j), cannot)) in - (* let (_, _, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of root) (typ_of root)) in - let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in - let subv = fix_eff_exp (E_aux (E_app (mk_id subrange_id, [root; index_i; index_j]), cannot)) in *) - - let id_pat = - match typ_opt with - | Some typ -> P_aux (P_typ (typ, P_aux (P_id child,cannot)), cannot) - | None -> P_aux (P_id child,cannot) in - let letbind = fix_eff_lb (LB_aux (LB_val (id_pat,subv),cannot)) in - (letbind, - (fun body -> fix_eff_exp (annot_exp (E_let (letbind,body)) l env (typ_of body))), - (rootname,childname)) in - - let p_aux = function - | ((P_as (P_aux (P_vector_concat pats,rannot'),rootid),decls),rannot) -> - let rtyp = Env.base_typ_of (env_of_annot rannot') (typ_of_annot rannot') in - let (start,last_idx) = (match vector_typ_args_of rtyp with - | (Nexp_aux (Nexp_constant start,_), Nexp_aux (Nexp_constant length,_), ord, _) -> - (start, if is_order_inc ord - then sub_big_int (add_big_int start length) unit_big_int - else add_big_int (sub_big_int start length) unit_big_int) - | _ -> - raise (Reporting_basic.err_unreachable (fst rannot') - ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in - let rec aux typ_opt (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = - let ctyp = Env.base_typ_of (env_of_annot cannot) (typ_of_annot cannot) in - let (_,length,ord,_) = vector_typ_args_of ctyp in - let (pos',index_j) = match length with - | Nexp_aux (Nexp_constant i,_) -> - if is_order_inc ord - then (add_big_int pos i, sub_big_int (add_big_int pos i) unit_big_int) - else (sub_big_int pos i, add_big_int (sub_big_int pos i) unit_big_int) - | Nexp_aux (_,l) -> - if is_last then (pos,last_idx) - else - raise - (Reporting_basic.err_unreachable - l ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) in - (match p with - (* if we see a named vector pattern, remove the name and remember to - declare it later *) - | P_as (P_aux (p,cannot),cname) -> - let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in - (pos', pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) - (* if we see a P_id variable, remember to declare it later *) - | P_id cname -> - let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in - (pos', pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) - | P_typ (typ, pat) -> aux (Some typ) (pos,pat_acc,decl_acc) (pat, is_last) - (* normal vector patterns are fine *) - | _ -> (pos', pat_acc @ [P_aux (p,cannot)],decl_acc)) in - let pats_tagged = tag_last pats in - let (_,pats',decls') = List.fold_left (aux None) (start,[],[]) pats_tagged in - - (* abuse P_vector_concat as a P_vector_const pattern: it has the of - patterns as an argument but they're meant to be consed together *) - (P_aux (P_as (P_aux (P_vector_concat pats',rannot'),rootid),rannot), decls @ decls') - | ((p,decls),annot) -> (P_aux (p,annot),decls) in - - { p_lit = (fun lit -> (P_lit lit,[])) - ; p_wild = (P_wild,[]) - ; p_as = (fun ((pat,decls),id) -> (P_as (pat,id),decls)) - ; p_typ = (fun (typ,(pat,decls)) -> (P_typ (typ,pat),decls)) - ; p_id = (fun id -> (P_id id,[])) - ; p_var = (fun ((pat,decls),kid) -> (P_var (pat,kid),decls)) - ; p_app = (fun (id,ps) -> let (ps,decls) = List.split ps in - (P_app (id,ps),List.flatten decls)) - ; p_record = (fun (ps,b) -> let (ps,decls) = List.split ps in - (P_record (ps,b),List.flatten decls)) - ; p_vector = (fun ps -> let (ps,decls) = List.split ps in - (P_vector ps,List.flatten decls)) - ; p_vector_concat = (fun ps -> let (ps,decls) = List.split ps in - (P_vector_concat ps,List.flatten decls)) - ; p_tup = (fun ps -> let (ps,decls) = List.split ps in - (P_tup ps,List.flatten decls)) - ; p_list = (fun ps -> let (ps,decls) = List.split ps in - (P_list ps,List.flatten decls)) - ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) - ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) - ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) - ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) - } in - - let (pat,decls) = fold_pat unname_vector_concat_elements pat in - - let decls = - let module S = Set.Make(String) in - - let roots_needed = - List.fold_right - (fun (_,(rootid,childid)) roots_needed -> - if S.mem childid roots_needed then - (* let _ = print_endline rootid in *) - S.add rootid roots_needed - else if String.length childid >= 3 && String.sub childid 0 2 = String.sub "v__" 0 2 then - roots_needed - else - S.add rootid roots_needed - ) decls S.empty in - List.filter - (fun (_,(_,childid)) -> - S.mem childid roots_needed || - String.length childid < 3 || - not (String.sub childid 0 2 = String.sub "v__" 0 2)) - decls in - - let (letbinds,decls) = - let (decls,_) = List.split decls in - List.split decls in - - let decls = List.fold_left (fun f g x -> f (g x)) (fun b -> b) decls in - - - (* at this point shouldn't have P_as patterns in P_vector_concat patterns any more, - all P_as and P_id vectors should have their declarations in decls. - Now flatten all vector_concat patterns *) - - let flatten = - let p_vector_concat ps = - let aux p acc = match p with - | (P_aux (P_vector_concat pats,_)) -> pats @ acc - | pat -> pat :: acc in - P_vector_concat (List.fold_right aux ps []) in - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat flatten pat in - - (* at this point pat should be a flat pattern: no vector_concat patterns - with vector_concats patterns as direct child-nodes anymore *) - - let range a b = - let rec aux a b = if gt_big_int a b then [] else a :: aux (add_big_int a unit_big_int) b in - if gt_big_int a b then List.rev (aux b a) else aux a b in - - let remove_vector_concats = - let p_vector_concat ps = - let aux acc (P_aux (p,annot),is_last) = - let env = env_of_annot annot in - let typ = Env.base_typ_of env (typ_of_annot annot) in - let eff = effect_of_annot (snd annot) in - let (l,_) = annot in - let wild _ = P_aux (P_wild,(gen_loc l, Some (env, bit_typ, eff))) in - if is_vector_typ typ then - match p, vector_typ_args_of typ with - | P_vector ps,_ -> acc @ ps - | _, (_,Nexp_aux (Nexp_constant length,_),_,_) -> - acc @ (List.map wild (range zero_big_int (sub_big_int length unit_big_int))) - | _, _ -> - (*if is_last then*) acc @ [wild zero_big_int] - else raise - (Reporting_basic.err_unreachable l - ("remove_vector_concats: Non-vector in vector-concat pattern " ^ - string_of_typ (typ_of_annot annot))) in - - let has_length (P_aux (p,annot)) = - let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in - match vector_typ_args_of typ with - | (_,Nexp_aux (Nexp_constant length,_),_,_) -> true - | _ -> false in - - let ps_tagged = tag_last ps in - let ps' = List.fold_left aux [] ps_tagged in - let last_has_length ps = List.exists (fun (p,b) -> b && has_length p) ps_tagged in - - if last_has_length ps then - P_vector ps' - else - (* If the last vector pattern in the vector_concat pattern has unknown - length we misuse the P_vector_concat constructor's argument to place in - the following way: P_vector_concat [x;y; ... ;z] should be mapped to the - pattern-match x :: y :: .. z, i.e. if x : 'a, then z : vector 'a. *) - P_vector_concat ps' in - - {id_pat_alg with p_vector_concat = p_vector_concat} in - - let pat = fold_pat remove_vector_concats pat in - - (pat,letbinds,decls) - -(* assumes there are no more E_internal expressions *) -let rewrite_exp_remove_vector_concat_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_case (e,ps) -> - let aux = function - | (Pat_aux (Pat_exp (pat,body),annot')) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - Pat_aux (Pat_exp (pat, decls (rewrite_rec body)),annot') - | (Pat_aux (Pat_when (pat,guard,body),annot')) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - Pat_aux (Pat_when (pat, decls (rewrite_rec guard), decls (rewrite_rec body)),annot') in - rewrap (E_case (rewrite_rec e, List.map aux ps)) - | E_let (LB_aux (LB_val (pat,v),annot'),body) -> - let (pat,_,decls) = remove_vector_concat_pat pat in - rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), - decls (rewrite_rec body))) - | exp -> rewrite_base full_exp - -let rewrite_fun_remove_vector_concat_pat - rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = - let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = - let (pat',_,decls) = remove_vector_concat_pat pat in - let exp' = decls (rewriters.rewrite_exp rewriters exp) in - (FCL_aux (FCL_Funcl (id,pat',exp'),(l,annot))) - in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) - -let rewrite_defs_remove_vector_concat (Defs defs) = - let rewriters = - {rewrite_exp = rewrite_exp_remove_vector_concat_pat; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp; - rewrite_fun = rewrite_fun_remove_vector_concat_pat; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} in - let rewrite_def d = - let d = rewriters.rewrite_def rewriters d in - match d with - | DEF_val (LB_aux (LB_val (pat,exp),a)) -> - let (pat,letbinds,_) = remove_vector_concat_pat pat in - let defvals = List.map (fun lb -> DEF_val lb) letbinds in - [DEF_val (LB_aux (LB_val (pat,exp),a))] @ defvals - | d -> [d] in - Defs (List.flatten (List.map rewrite_def defs)) - -(* A few helper functions for rewriting guarded pattern clauses. - Used both by the rewriting of P_when and separately by the rewriting of - bitvectors in parameter patterns of function clauses *) - -let remove_wildcards pre (P_aux (_,(l,_)) as pat) = - fold_pat - {id_pat_alg with - p_aux = function - | (P_wild,(l,annot)) -> P_aux (P_id (fresh_id pre l),(l,annot)) - | (p,annot) -> P_aux (p,annot) } - pat - -(* Check if one pattern subsumes the other, and if so, calculate a - substitution of variables that are used in the same position. - TODO: Check somewhere that there are no variable clashes (the same variable - name used in different positions of the patterns) - *) -let rec subsumes_pat (P_aux (p1,annot1) as pat1) (P_aux (p2,annot2) as pat2) = - let rewrap p = P_aux (p,annot1) in - let subsumes_list s pats1 pats2 = - if List.length pats1 = List.length pats2 - then - let subs = List.map2 s pats1 pats2 in - List.fold_right - (fun p acc -> match p, acc with - | Some subst, Some substs -> Some (subst @ substs) - | _ -> None) - subs (Some []) - else None in - match p1, p2 with - | P_lit (L_aux (lit1,_)), P_lit (L_aux (lit2,_)) -> - if lit1 = lit2 then Some [] else None - | P_as (pat1,_), _ -> subsumes_pat pat1 pat2 - | _, P_as (pat2,_) -> subsumes_pat pat1 pat2 - | P_typ (_,pat1), _ -> subsumes_pat pat1 pat2 - | _, P_typ (_,pat2) -> subsumes_pat pat1 pat2 - | P_id (Id_aux (id1,_) as aid1), P_id (Id_aux (id2,_) as aid2) -> - if id1 = id2 then Some [] - else if Env.lookup_id aid1 (env_of_annot annot1) = Unbound && - Env.lookup_id aid2 (env_of_annot annot2) = Unbound - then Some [(id2,id1)] else None - | P_id id1, _ -> - if Env.lookup_id id1 (env_of_annot annot1) = Unbound then Some [] else None - | P_wild, _ -> Some [] - | P_app (Id_aux (id1,l1),args1), P_app (Id_aux (id2,_),args2) -> - if id1 = id2 then subsumes_list subsumes_pat args1 args2 else None - | P_record (fps1,b1), P_record (fps2,b2) -> - if b1 = b2 then subsumes_list subsumes_fpat fps1 fps2 else None - | P_vector pats1, P_vector pats2 - | P_vector_concat pats1, P_vector_concat pats2 - | P_tup pats1, P_tup pats2 - | P_list pats1, P_list pats2 -> - subsumes_list subsumes_pat pats1 pats2 - | P_list (pat1 :: pats1), P_cons _ -> - subsumes_pat (rewrap (P_cons (pat1, rewrap (P_list pats1)))) pat2 - | P_cons _, P_list (pat2 :: pats2)-> - subsumes_pat pat1 (rewrap (P_cons (pat2, rewrap (P_list pats2)))) - | P_cons (pat1, pats1), P_cons (pat2, pats2) -> - (match subsumes_pat pat1 pat2, subsumes_pat pats1 pats2 with - | Some substs1, Some substs2 -> Some (substs1 @ substs2) - | _ -> None) - | _ -> None -and subsumes_fpat (FP_aux (FP_Fpat (id1,pat1),_)) (FP_aux (FP_Fpat (id2,pat2),_)) = - if id1 = id2 then subsumes_pat pat1 pat2 else None - -let equiv_pats pat1 pat2 = - match subsumes_pat pat1 pat2, subsumes_pat pat2 pat1 with - | Some _, Some _ -> true - | _, _ -> false - -let subst_id_pat pat (id1,id2) = - let p_id (Id_aux (id,l)) = (if id = id1 then P_id (Id_aux (id2,l)) else P_id (Id_aux (id,l))) in - fold_pat {id_pat_alg with p_id = p_id} pat - -let subst_id_exp exp (id1,id2) = - (* TODO Don't substitute bound occurrences inside let expressions etc *) - let e_id (Id_aux (id,l)) = (if id = id1 then E_id (Id_aux (id2,l)) else E_id (Id_aux (id,l))) in - fold_exp {id_exp_alg with e_id = e_id} exp - -let rec pat_to_exp (P_aux (pat,(l,annot))) = - let rewrap e = E_aux (e,(l,annot)) in - match pat with - | P_lit lit -> rewrap (E_lit lit) - | P_wild -> raise (Reporting_basic.err_unreachable l - "pat_to_exp given wildcard pattern") - | P_as (pat,id) -> rewrap (E_id id) - | P_typ (_,pat) -> pat_to_exp pat - | P_id id -> rewrap (E_id id) - | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) - | P_record (fpats,b) -> - rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) - | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) - | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l - "pat_to_exp not implemented for P_vector_concat") - (* We assume that vector concatenation patterns have been transformed - away already *) - | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) - | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) - | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) -and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = - FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) - -let case_exp e t cs = - let l = get_loc_exp e in - let env = env_of e in - let annot = (get_loc_exp e, Some (env_of e, t, no_effect)) in - match cs with - | [(P_aux (P_id id, pannot) as pat, body, _)] -> - fix_eff_exp (annot_exp (E_let (LB_aux (LB_val (pat, e), pannot), body)) l env t) - | _ -> - let pexp (pat,body,annot) = Pat_aux (Pat_exp (pat,body),annot) in - let ps = List.map pexp cs in - (* let efr = union_effs (List.map effect_of_pexp ps) in *) - fix_eff_exp (annot_exp (E_case (e,ps)) l env t) - -let rewrite_guarded_clauses l cs = - let rec group clauses = - let add_clause (pat,cls,annot) c = (pat,cls @ [c],annot) in - let rec group_aux current acc = (function - | ((pat,guard,body,annot) as c) :: cs -> - let (current_pat,_,_) = current in - (match subsumes_pat current_pat pat with - | Some substs -> - let pat' = List.fold_left subst_id_pat pat substs in - let guard' = (match guard with - | Some exp -> Some (List.fold_left subst_id_exp exp substs) - | None -> None) in - let body' = List.fold_left subst_id_exp body substs in - let c' = (pat',guard',body',annot) in - group_aux (add_clause current c') acc cs - | None -> - let pat = remove_wildcards "g__" pat in - group_aux (pat,[c],annot) (acc @ [current]) cs) - | [] -> acc @ [current]) in - let groups = match clauses with - | ((pat,guard,body,annot) as c) :: cs -> - group_aux (remove_wildcards "g__" pat, [c], annot) [] cs - | _ -> - raise (Reporting_basic.err_unreachable l - "group given empty list in rewrite_guarded_clauses") in - List.map (fun cs -> if_pexp cs) groups - and if_pexp (pat,cs,annot) = (match cs with - | c :: _ -> - (* fix_eff_pexp (pexp *) - let body = if_exp pat cs in - let pexp = fix_eff_pexp (Pat_aux (Pat_exp (pat,body),annot)) in - let (Pat_aux (_,annot)) = pexp in - (pat, body, annot) - | [] -> - raise (Reporting_basic.err_unreachable l - "if_pexp given empty list in rewrite_guarded_clauses")) - and if_exp current_pat = (function - | (pat,guard,body,annot) :: ((pat',guard',body',annot') as c') :: cs -> - (match guard with - | Some exp -> - let else_exp = - if equiv_pats current_pat pat' - then if_exp current_pat (c' :: cs) - else case_exp (pat_to_exp current_pat) (typ_of body') (group (c' :: cs)) in - fix_eff_exp (annot_exp (E_if (exp,body,else_exp)) (fst annot) (env_of exp) (typ_of body)) - | None -> body) - | [(pat,guard,body,annot)] -> body - | [] -> - raise (Reporting_basic.err_unreachable l - "if_exp given empty list in rewrite_guarded_clauses")) in - group cs - -let bitwise_and_exp exp1 exp2 = - let (E_aux (_,(l,_))) = exp1 in - let andid = Id_aux (Id "and_bool", gen_loc l) in - annot_exp (E_app(andid,[exp1;exp2])) l (env_of exp1) bool_typ - -let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with -| P_lit _ | P_wild | P_id _ -> false -| P_as (pat,_) | P_typ (_,pat) -> contains_bitvector_pat pat -| P_vector _ | P_vector_concat _ -> - let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in - is_bitvector_typ typ -| P_app (_,pats) | P_tup pats | P_list pats -> - List.exists contains_bitvector_pat pats -| P_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps -| P_record (fpats,_) -> - List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats - -let contains_bitvector_pexp = function -| Pat_aux (Pat_exp (pat,_),_) | Pat_aux (Pat_when (pat,_,_),_) -> - contains_bitvector_pat pat - -(* Rewrite bitvector patterns to guarded patterns *) - -let remove_bitvector_pat pat = - - let env = try pat_env_of pat with _ -> Env.empty in - - (* first introduce names for bitvector patterns *) - let name_bitvector_roots = - { p_lit = (fun lit -> P_lit lit) - ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) - ; p_wild = P_wild - ; p_as = (fun (pat,id) -> P_as (pat true,id)) - ; p_id = (fun id -> P_id id) - ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) - ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) - ; p_record = (fun (fpats,b) -> P_record (fpats, b)) - ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) - ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) - ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) - ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) - ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) - ; p_aux = - (fun (pat,annot) contained_in_p_as -> - let env = env_of_annot annot in - let t = Env.base_typ_of env (typ_of_annot annot) in - let (l,_) = annot in - match pat, is_bitvector_typ t, contained_in_p_as with - | P_vector _, true, false -> - P_aux (P_as (P_aux (pat,annot),fresh_id "b__" l), annot) - | _ -> P_aux (pat,annot) - ) - ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) - ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) - } in - let pat = (fold_pat name_bitvector_roots pat) false in - - (* Then collect guard expressions testing whether the literal bits of a - bitvector pattern match those of a given bitvector, and collect let - bindings for the bits bound by P_id or P_as patterns *) - - (* Helper functions for generating guard expressions *) - let access_bit_exp rootid l typ idx = - let root = annot_exp (E_id rootid) l env typ in - (* FIXME *) - annot_exp (E_vector_access (root, simple_num l idx)) l env bit_typ in - (*let env = env_of_annot rannot in - let t = Env.base_typ_of env (typ_of_annot rannot) in - let (_, _, ord, _) = vector_typ_args_of t in - let access_id = if is_order_inc ord then "bitvector_access_inc" else "bitvector_access_dec" in - E_aux (E_app (mk_id access_id, [root; simple_num l idx]), simple_annot l bit_typ) in*) - - let test_bit_exp rootid l typ idx exp = - let rannot = (l, Some (env_of exp, typ, no_effect)) in - let elem = access_bit_exp rootid l typ idx in - Some (annot_exp (E_app (mk_id "eq", [elem; exp])) l env bool_typ) in - - let test_subvec_exp rootid l typ i j lits = - let (start, length, ord, _) = vector_typ_args_of typ in - let length' = nint (List.length lits) in - let start' = - if is_order_inc ord then nint 0 - else nminus length' (nint 1) in - let typ' = vector_typ start' length' ord bit_typ in - let subvec_exp = - match start, length with - | Nexp_aux (Nexp_constant s, _), Nexp_aux (Nexp_constant l, _) - when eq_big_int s i && eq_big_int l (big_int_of_int (List.length lits)) -> - E_id rootid - | _ -> - (*if vec_start t = i && vec_length t = List.length lits - then E_id rootid - else*) - E_vector_subrange ( - annot_exp (E_id rootid) l env typ, - simple_num l i, - simple_num l j) in - (* let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in - E_app (mk_id subrange_id, [E_aux (E_id rootid, simple_annot l typ); simple_num l i; simple_num l j]) in *) - annot_exp (E_app( - Id_aux (Id "eq_vec", gen_loc l), - [annot_exp subvec_exp l env typ'; - annot_exp (E_vector lits) l env typ'])) l env bool_typ in - - let letbind_bit_exp rootid l typ idx id = - let rannot = simple_annot l typ in - let elem = access_bit_exp rootid l typ idx in - let e = annot_pat (P_id id) l env bit_typ in - let letbind = LB_aux (LB_val (e,elem), (l, Some (env, bit_typ, no_effect))) in - let letexp = (fun body -> - let (E_aux (_,(_,bannot))) = body in - annot_exp (E_let (letbind,body)) l env (typ_of body)) in - (letexp, letbind) in - - let compose_guards guards = - let conj g1 g2 = match g1, g2 with - | Some g1, Some g2 -> Some (bitwise_and_exp g1 g2) - | Some g1, None -> Some g1 - | None, Some g2 -> Some g2 - | None, None -> None in - List.fold_right conj guards None in - - let flatten_guards_decls gd = - let (guards,decls,letbinds) = Util.split3 gd in - (compose_guards guards, (List.fold_right (@@) decls), List.flatten letbinds) in - - (* Collect guards and let bindings *) - let guard_bitvector_pat = - let collect_guards_decls ps rootid t = - let (start,_,ord,_) = vector_typ_args_of t in - let rec collect current (guards,dls) idx ps = - let idx' = if is_order_inc ord then add_big_int idx unit_big_int else sub_big_int idx unit_big_int in - (match ps with - | pat :: ps' -> - (match pat with - | P_aux (P_lit lit, (l,annot)) -> - let e = E_aux (E_lit lit, (gen_loc l, annot)) in - let current' = (match current with - | Some (l,i,j,lits) -> Some (l,i,idx,lits @ [e]) - | None -> Some (l,idx,idx,[e])) in - collect current' (guards, dls) idx' ps' - | P_aux (P_as (pat',id), (l,annot)) -> - let dl = letbind_bit_exp rootid l t idx id in - collect current (guards, dls @ [dl]) idx (pat' :: ps') - | _ -> - let dls' = (match pat with - | P_aux (P_id id, (l,annot)) -> - dls @ [letbind_bit_exp rootid l t idx id] - | _ -> dls) in - let guards' = (match current with - | Some (l,i,j,lits) -> - guards @ [Some (test_subvec_exp rootid l t i j lits)] - | None -> guards) in - collect None (guards', dls') idx' ps') - | [] -> - let guards' = (match current with - | Some (l,i,j,lits) -> - guards @ [Some (test_subvec_exp rootid l t i j lits)] - | None -> guards) in - (guards',dls)) in - let (guards,dls) = match start with - | Nexp_aux (Nexp_constant s, _) -> - collect None ([],[]) s ps - | _ -> - let (P_aux (_, (l,_))) = pat in - raise (Reporting_basic.err_unreachable l - "guard_bitvector_pat called on pattern with non-constant start index") in - let (decls,letbinds) = List.split dls in - (compose_guards guards, List.fold_right (@@) decls, letbinds) in - - let collect_guards_decls_indexed ips rootid t = - let rec guard_decl (idx,pat) = (match pat with - | P_aux (P_lit lit, (l,annot)) -> - let exp = E_aux (E_lit lit, (l,annot)) in - (test_bit_exp rootid l t idx exp, (fun b -> b), []) - | P_aux (P_as (pat',id), (l,annot)) -> - let (guard,decls,letbinds) = guard_decl (idx,pat') in - let (letexp,letbind) = letbind_bit_exp rootid l t idx id in - (guard, decls >> letexp, letbind :: letbinds) - | P_aux (P_id id, (l,annot)) -> - let (letexp,letbind) = letbind_bit_exp rootid l t idx id in - (None, letexp, [letbind]) - | _ -> (None, (fun b -> b), [])) in - let (guards,decls,letbinds) = Util.split3 (List.map guard_decl ips) in - (compose_guards guards, List.fold_right (@@) decls, List.flatten letbinds) in - - { p_lit = (fun lit -> (P_lit lit, (None, (fun b -> b), []))) - ; p_wild = (P_wild, (None, (fun b -> b), [])) - ; p_as = (fun ((pat,gdls),id) -> (P_as (pat,id), gdls)) - ; p_typ = (fun (typ,(pat,gdls)) -> (P_typ (typ,pat), gdls)) - ; p_id = (fun id -> (P_id id, (None, (fun b -> b), []))) - ; p_var = (fun ((pat,gdls),kid) -> (P_var (pat,kid), gdls)) - ; p_app = (fun (id,ps) -> let (ps,gdls) = List.split ps in - (P_app (id,ps), flatten_guards_decls gdls)) - ; p_record = (fun (ps,b) -> let (ps,gdls) = List.split ps in - (P_record (ps,b), flatten_guards_decls gdls)) - ; p_vector = (fun ps -> let (ps,gdls) = List.split ps in - (P_vector ps, flatten_guards_decls gdls)) - ; p_vector_concat = (fun ps -> let (ps,gdls) = List.split ps in - (P_vector_concat ps, flatten_guards_decls gdls)) - ; p_tup = (fun ps -> let (ps,gdls) = List.split ps in - (P_tup ps, flatten_guards_decls gdls)) - ; p_list = (fun ps -> let (ps,gdls) = List.split ps in - (P_list ps, flatten_guards_decls gdls)) - ; p_cons = (fun ((p,gdls),(p',gdls')) -> - (P_cons (p,p'), flatten_guards_decls [gdls;gdls'])) - ; p_aux = (fun ((pat,gdls),annot) -> - let env = env_of_annot annot in - let t = Env.base_typ_of env (typ_of_annot annot) in - (match pat, is_bitvector_typ t with - | P_as (P_aux (P_vector ps, _), id), true -> - (P_aux (P_id id, annot), collect_guards_decls ps id t) - | _, _ -> (P_aux (pat,annot), gdls))) - ; fP_aux = (fun ((fpat,gdls),annot) -> (FP_aux (fpat,annot), gdls)) - ; fP_Fpat = (fun (id,(pat,gdls)) -> (FP_Fpat (id,pat), gdls)) - } in - fold_pat guard_bitvector_pat pat - -let rewrite_exp_remove_bitvector_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_case (e,ps) - when List.exists contains_bitvector_pexp ps -> - let rewrite_pexp = function - | Pat_aux (Pat_exp (pat,body),annot') -> - let (pat',(guard',decls,_)) = remove_bitvector_pat pat in - let body' = decls (rewrite_rec body) in - (match guard' with - | Some guard' -> Pat_aux (Pat_when (pat', guard', body'), annot') - | None -> Pat_aux (Pat_exp (pat', body'), annot')) - | Pat_aux (Pat_when (pat,guard,body),annot') -> - let (pat',(guard',decls,_)) = remove_bitvector_pat pat in - let body' = decls (rewrite_rec body) in - (match guard' with - | Some guard' -> Pat_aux (Pat_when (pat', bitwise_and_exp guard guard', body'), annot') - | None -> Pat_aux (Pat_when (pat', guard, body'), annot')) in - rewrap (E_case (e, List.map rewrite_pexp ps)) - | E_let (LB_aux (LB_val (pat,v),annot'),body) -> - let (pat,(_,decls,_)) = remove_bitvector_pat pat in - rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), - decls (rewrite_rec body))) - | _ -> rewrite_base full_exp - -let rewrite_fun_remove_bitvector_pat - rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = - let _ = reset_fresh_name_counter () in - (* TODO Can there be clauses with different id's in one FD_function? *) - let funcls = match funcls with - | (FCL_aux (FCL_Funcl(id,_,_),_) :: _) -> - let clause (FCL_aux (FCL_Funcl(_,pat,exp),annot)) = - let (pat,(guard,decls,_)) = remove_bitvector_pat pat in - let exp = decls (rewriters.rewrite_exp rewriters exp) in - (pat,guard,exp,annot) in - let cs = rewrite_guarded_clauses l (List.map clause funcls) in - List.map (fun (pat,exp,annot) -> FCL_aux (FCL_Funcl(id,pat,exp),annot)) cs - | _ -> funcls (* TODO is the empty list possible here? *) in - FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot)) - -let rewrite_defs_remove_bitvector_pats (Defs defs) = - let rewriters = - {rewrite_exp = rewrite_exp_remove_bitvector_pat; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp; - rewrite_fun = rewrite_fun_remove_bitvector_pat; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base } in - let rewrite_def d = - let d = rewriters.rewrite_def rewriters d in - match d with - | DEF_val (LB_aux (LB_val (pat,exp),a)) -> - let (pat',(_,_,letbinds)) = remove_bitvector_pat pat in - let defvals = List.map (fun lb -> DEF_val lb) letbinds in - [DEF_val (LB_aux (LB_val (pat',exp),a))] @ defvals - | d -> [d] in - (* FIXME See above in rewrite_sizeof *) - (* fst (check initial_env ( *) - Defs (List.flatten (List.map rewrite_def defs)) - (* )) *) - - -(* Remove pattern guards by rewriting them to if-expressions within the - pattern expression. Shares code with the rewriting of bitvector patterns. *) -let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = - let rewrap e = E_aux (e,(l,annot)) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - let is_guarded_pexp = function - | Pat_aux (Pat_when (_,_,_),_) -> true - | _ -> false in - match exp with - | E_case (e,ps) - when List.exists is_guarded_pexp ps -> - let clause = function - | Pat_aux (Pat_exp (pat, body), annot) -> - (pat, None, rewrite_rec body, annot) - | Pat_aux (Pat_when (pat, guard, body), annot) -> - (pat, Some guard, rewrite_rec body, annot) in - let clauses = rewrite_guarded_clauses l (List.map clause ps) in - if (effectful e) then - let e = rewrite_rec e in - let (E_aux (_,(el,eannot))) = e in - let pat_e' = fresh_id_pat "p__" (el, Some (env_of e, typ_of e, no_effect)) in - let exp_e' = pat_to_exp pat_e' in - let letbind_e = LB_aux (LB_val (pat_e',e), (el,eannot)) in - let exp' = case_exp exp_e' (typ_of full_exp) clauses in - rewrap (E_let (letbind_e, exp')) - else case_exp e (typ_of full_exp) clauses - | _ -> rewrite_base full_exp - -let rewrite_defs_guarded_pats = - rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp_guarded_pats } - - -let id_is_local_var id env = match Env.lookup_id id env with - | Local _ -> true - | _ -> false - -let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false - | LEXP_id id - | LEXP_cast (_, id) -> id_is_local_var id env - | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local lexp env) lexps - | LEXP_vector (lexp,_) - | LEXP_vector_range (lexp,_,_) - | LEXP_field (lexp,_) -> lexp_is_local lexp env - -let id_is_unbound id env = match Env.lookup_id id env with - | Unbound -> true - | _ -> false - -let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with - | LEXP_memory _ -> false - | LEXP_id id - | LEXP_cast (_, id) -> id_is_unbound id env - | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local_intro lexp env) lexps - | LEXP_vector (lexp,_) - | LEXP_vector_range (lexp,_,_) - | LEXP_field (lexp,_) -> lexp_is_local_intro lexp env - -let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with - | Some (_, _, eff) -> effectful_effs eff - | _ -> false - -let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = - match lexp with - | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) - | LEXP_vector (lexp, e) -> - let (lhs, rhs) = rewrite_local_lexp lexp in - (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) - | LEXP_vector_range (lexp, e1, e2) -> - let (lhs, rhs) = rewrite_local_lexp lexp in - (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) - | LEXP_field (lexp, id) -> - let (lhs, rhs) = rewrite_local_lexp lexp in - let (LEXP_aux (_, recannot)) = lexp in - let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in - (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), recannot)))) - | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) - -(*Expects to be called after rewrite_defs; thus the following should not appear: - internal_exp of any form - lit vectors in patterns or expressions - *) -let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = - let rewrap e = E_aux (e,annot) in - let rewrap_effects e eff = - E_aux (e, (l,Some (env_of_annot annot, typ_of_annot annot, eff))) in - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_block exps -> - let rec walker exps = match exps with - | [] -> [] - | (E_aux(E_assign(le,e), ((l, Some (env,typ,eff)) as annot)) as exp)::exps - when lexp_is_local_intro le env && not (lexp_is_effectful le) -> - let (le', re') = rewrite_local_lexp le in - let e' = re' (rewrite_base e) in - let exps' = walker exps in - let effects = union_eff_exps exps' in - let block = E_aux (E_block exps', (l, Some (env, unit_typ, effects))) in - [fix_eff_exp (E_aux (E_internal_let(le', e', block), annot))] - (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> - let vars_t = introduced_variables t in - let vars_e = introduced_variables e in - let new_vars = Envmap.intersect vars_t vars_e in - if Envmap.is_empty new_vars - then (rewrite_base exp)::walker exps - else - let new_nmap = match nmap with - | None -> Some(Nexpmap.empty,new_vars) - | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in - let c' = rewrite_base c in - let t' = rewriters.rewrite_exp rewriters new_nmap t in - let e' = rewriters.rewrite_exp rewriters new_nmap e in - let exps' = walker exps in - fst ((Envmap.fold - (fun (res,effects) i (t,e) -> - let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot bit_t)) in - let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), - (Parse_ast.Generated l, simple_annot nat_t)) in - let set_exp = - match t.t with - | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit - | Tapp("range", _) | Tapp("atom", _) -> rangelit - | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) - | Tapp(("reg"|"register"),[TA_typ ({t = Tapp("vector", - [_;_;_;TA_typ ( {t=Tid "bit"} - | {t=Tabbrev(_,{t=Tid "bit"})})])})]) - | Tabbrev(_,{t = Tapp("vector", - [_;_;_;TA_typ ( {t=Tid "bit"} - | {t=Tabbrev(_,{t=Tid "bit"})})])}) -> - E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, - (Parse_ast.Generated l,simple_annot bit_t))), - (Parse_ast.Generated l, simple_annot t)) - | _ -> e in - let unioneffs = union_effects effects (get_effsum_exp set_exp) in - ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), - (Parse_ast.Generated l, (tag_annot t Emp_intro))), - set_exp, - E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), - (Parse_ast.Generated l, simple_annot_efr unit_t unioneffs))],unioneffs))) - (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars)*) - | e::exps -> (rewrite_rec e)::(walker exps) - in - rewrap (E_block (walker exps)) - | E_assign(le,e) - when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> - let (le', re') = rewrite_local_lexp le in - let e' = re' (rewrite_base e) in - let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in - fix_eff_exp (E_aux (E_internal_let(le', e', block), annot)) - | _ -> rewrite_base full_exp - -let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = - let rewrap le = LEXP_aux(le,annot) in - let rewrite_base = rewrite_lexp rewriters in - match lexp, annot with - | (LEXP_id id | LEXP_cast (_,id)), (l, Some (env, typ, eff)) -> - (match Env.lookup_id id env with - | Unbound | Local _ -> - LEXP_aux (lexp, (l, Some (env, typ, union_effects eff (mk_effect [BE_lset])))) - | _ -> rewrap lexp) - | _ -> rewrite_base le - - -let rewrite_defs_exp_lift_assign defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_lift_assign_intro; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; - rewrite_lexp = rewrite_lexp_lift_assign_intro; - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} defs - -(*let rewrite_exp_separate_ints rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = - (*let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with - | Base((tparms,t),tag,nexps,eff,cum_eff,bounds) -> tparms,t,tag,nexps,eff,cum_eff,bounds - | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in*) - let rewrap e = E_aux (e,annot) in - (*let rewrap_effects e effsum = - E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in*) - let rewrite_rec = rewriters.rewrite_exp rewriters in - let rewrite_base = rewrite_exp rewriters in - match exp with - | E_lit (L_aux (((L_num _) as lit),_)) -> - (match (is_within_machine64 t nexps) with - | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp - | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp - | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), - (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) - | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) - | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) - | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) - | E_for (id, e1, e2, e3, o, body) -> - rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) - | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) - | E_vector_subrange (vec,i1,i2) -> - rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) - | E_vector_update (vec,index,new_v) -> - rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) - | E_vector_update_subrange (vec,i1,i2,new_v) -> - rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) - | E_case (exp ,pexps) -> - rewrap (E_case (rewrite_rec exp, - (List.map - (fun (Pat_aux (Pat_exp(p,e),pannot)) -> - Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) - | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) - | E_internal_let (lexp,exp,body) -> - rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) - | _ -> rewrite_base full_exp - -let rewrite_defs_separate_numbs defs = rewrite_defs_base - {rewrite_exp = rewrite_exp_separate_ints; - rewrite_pat = rewrite_pat; - rewrite_let = rewrite_let; (*will likely need a new one?*) - rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) - rewrite_fun = rewrite_fun; - rewrite_def = rewrite_def; - rewrite_defs = rewrite_defs_base} defs*) - -let rewrite_defs_early_return = - let is_return (E_aux (exp, _)) = match exp with - | E_return _ -> true - | _ -> false in - - let get_return (E_aux (e, (l, _)) as exp) = match e with - | E_return e -> e - | _ -> exp in - - let e_block es = - match es with - | [E_aux (e, _)] -> e - | _ :: _ when is_return (Util.last es) -> - let (E_aux (_, annot) as e) = get_return (Util.last es) in - E_return (E_aux (E_block (Util.butlast es @ [get_return e]), annot)) - | _ -> E_block es in - - let e_if (e1, e2, e3) = - if is_return e2 && is_return e3 then - let (E_aux (_, annot)) = get_return e2 in - E_return (E_aux (E_if (e1, get_return e2, get_return e3), annot)) - else E_if (e1, e2, e3) in - - let e_case (e, pes) = - let is_return_pexp (Pat_aux (pexp, _)) = match pexp with - | Pat_exp (_, e) | Pat_when (_, _, e) -> is_return e in - let get_return_pexp (Pat_aux (pexp, a)) = match pexp with - | Pat_exp (p, e) -> Pat_aux (Pat_exp (p, get_return e), a) - | Pat_when (p, g, e) -> Pat_aux (Pat_when (p, g, get_return e), a) in - let annot = match List.map get_return_pexp pes with - | Pat_aux (Pat_exp (_, E_aux (_, annot)), _) :: _ -> annot - | Pat_aux (Pat_when (_, _, E_aux (_, annot)), _) :: _ -> annot - | [] -> (Parse_ast.Unknown, None) in - if List.for_all is_return_pexp pes - then E_return (E_aux (E_case (e, List.map get_return_pexp pes), annot)) - else E_case (e, pes) in - - let e_aux (exp, (l, annot)) = - let full_exp = fix_eff_exp (E_aux (exp, (l, annot))) in - match annot with - | Some (env, typ, eff) when is_return full_exp -> - (* Add escape effect annotation, since we use the exception mechanism - of the state monad to implement early return in the Lem backend *) - let annot' = Some (env, typ, union_effects eff (mk_effect [BE_escape])) in - E_aux (exp, (l, annot')) - | _ -> full_exp in - - let rewrite_funcl_early_return _ (FCL_aux (FCL_Funcl (id, pat, exp), a)) = - let exp = - exp - (* Pull early returns out as far as possible *) - |> fold_exp { id_exp_alg with e_block = e_block; e_if = e_if; e_case = e_case } - (* Remove singleton E_return *) - |> get_return - (* Fix effect annotations *) - |> fold_exp { id_exp_alg with e_aux = e_aux } in - let a = match a with - | (l, Some (env, typ, eff)) -> - (l, Some (env, typ, union_effects eff (effect_of exp))) - | _ -> a in - FCL_aux (FCL_Funcl (id, pat, exp), a) in - - let rewrite_fun_early_return rewriters - (FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, funcls), a)) = - FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, - List.map (rewrite_funcl_early_return rewriters) funcls), a) in - - rewrite_defs_base { rewriters_base with rewrite_fun = rewrite_fun_early_return } - -(* Propagate effects of functions, if effect checking and propagation - have not been performed already by the type checker. *) -let rewrite_fix_val_specs (Defs defs) = - let find_vs env val_specs id = - try Bindings.find id val_specs with - | Not_found -> - begin - try Env.get_val_spec id env with - | _ -> - raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) - ("No val spec found for " ^ string_of_id id)) - end - in - - let add_eff_to_vs eff = function - | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff'), a)) -> - (tq, Typ_aux (Typ_fn (args_t, ret_t, union_effects eff eff'), a)) - | vs -> vs - in - - let eff_of_vs = function - | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> eff - | _ -> no_effect - in - - let e_aux val_specs (exp, (l, annot)) = - match fix_eff_exp (E_aux (exp, (l, annot))) with - | E_aux (E_app_infix (_, f, _) as exp, (l, Some (env, typ, eff))) - | E_aux (E_app (f, _) as exp, (l, Some (env, typ, eff))) -> - let vs = find_vs env val_specs f in - let env = Env.update_val_spec f vs env in - E_aux (exp, (l, Some (env, typ, union_effects eff (eff_of_vs vs)))) - | e_aux -> e_aux - in - - let rewrite_exp val_specs = fold_exp { id_exp_alg with e_aux = e_aux val_specs } in - - let rewrite_funcl (val_specs, funcls) (FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))) = - let exp = propagate_exp_effect (rewrite_exp val_specs exp) in - let vs, eff = match find_vs (env_of_annot (l, annot)) val_specs id with - | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> - let eff' = union_effects eff (effect_of exp) in - let args_t' = rewrite_typ_nexp_ids (env_of exp) (pat_typ_of pat) in - let ret_t' = rewrite_typ_nexp_ids (env_of exp) (typ_of exp) in - (tq, Typ_aux (Typ_fn (args_t', ret_t', eff'), a)), eff' - in - let annot = add_effect_annot annot eff in - (Bindings.add id vs val_specs, - funcls @ [FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))]) - in - - let rewrite_fundef (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) = - let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in - (* Repeat once to cross-propagate effects between clauses *) - let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in - let is_funcl_rec (FCL_aux (FCL_Funcl (id, _, exp), _)) = - fst (fold_exp - { (compute_exp_alg false (||) ) with - e_app = (fun (f, es) -> - let (rs, es) = List.split es in - (List.fold_left (||) (string_of_id f = string_of_id id) rs, - E_app (f, es))); - e_app_infix = (fun ((r1,e1), f, (r2,e2)) -> - (r1 || r2 || (string_of_id f = string_of_id id), - E_app_infix (e1, f, e2))) } - exp) - in - let recopt = - if List.exists is_funcl_rec funcls then - Rec_aux (Rec_rec, Parse_ast.Unknown) - else recopt - in - (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) in - - let rec rewrite_fundefs (val_specs, fundefs) = - match fundefs with - | fundef :: fundefs -> - let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in - let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in - (val_specs, fundef :: fundefs) - | [] -> (val_specs, []) in - - let rewrite_def (val_specs, defs) = function - | DEF_fundef fundef -> - let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in - (val_specs, defs @ [DEF_fundef fundef]) - | DEF_internal_mutrec fundefs -> - let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in - (val_specs, defs @ [DEF_internal_mutrec fundefs]) - | DEF_val (LB_aux (LB_val (pat, exp), a)) -> - (val_specs, defs @ [DEF_val (LB_aux (LB_val (pat, rewrite_exp val_specs exp), a))]) - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) -> - let typschm, val_specs = - if Bindings.mem id val_specs then begin - let (tq, typ) = Bindings.find id val_specs in - TypSchm_aux (TypSchm_ts (tq, typ), Parse_ast.Unknown), val_specs - end else begin - let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in - typschm, Bindings.add id (tq, typ) val_specs - end - in - (val_specs, defs @ [DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a))]) - | def -> (val_specs, defs @ [def]) - in - - let rewrite_val_specs val_specs = function - | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) - when Bindings.mem id val_specs -> - let typschm = match typschm with - | TypSchm_aux (TypSchm_ts (tq, typ), l) -> - let (tq, typ) = Bindings.find id val_specs in - TypSchm_aux (TypSchm_ts (tq, typ), l) - in - DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) - | def -> def - in - - let (val_specs, defs) = List.fold_left rewrite_def (Bindings.empty, []) defs in - let defs = List.map (rewrite_val_specs val_specs) defs in - - (* if !Type_check.opt_no_effects - then *) - Defs defs - (* else Defs defs *) - -(* Turn constraints into numeric expressions with sizeof *) -let rewrite_constraint = - let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux) - and rewrite_nc_aux = function - | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) - | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) - | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) - | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) - | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2) - | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2) - | NC_false -> E_lit (mk_lit L_false) - | NC_true -> E_lit (mk_lit L_true) - | NC_set (kid, ints) -> - unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (nc_eq (nvar kid) (nconstant int))) nc_true ints)) - in - let rewrite_e_aux (E_aux (e_aux, _) as exp) = - match e_aux with - | E_constraint nc -> - check_exp (env_of exp) (rewrite_nc nc) bool_typ - | _ -> exp - in - - let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in - - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) } - -let rewrite_type_union_typs rw_typ (Tu_aux (tu, annot)) = - match tu with - | Tu_id id -> Tu_aux (Tu_id id, annot) - | Tu_ty_id (typ, id) -> Tu_aux (Tu_ty_id (rw_typ typ, id), annot) - -let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = - match td with - | TD_abbrev (id, nso, typschm) -> TD_aux (TD_abbrev (id, nso, rw_typschm typschm), annot) - | TD_record (id, nso, typq, typ_ids, flag) -> - TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) - | TD_variant (id, nso, typq, tus, flag) -> - TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) - | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) - | TD_register (id, n1, n2, ranges) -> TD_aux (TD_register (id, n1, n2, ranges), annot) - -(* FIXME: other reg_dec types *) -let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = - match ds with - | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot) - | _ -> assert false - -(* Remove overload definitions and cast val specs from the - specification because the interpreter doesn't know about them.*) -let rewrite_overload_cast (Defs defs) = - let remove_cast_vs (VS_aux (vs_aux, annot)) = - match vs_aux with - | VS_val_spec (typschm, id, ext, _) -> VS_aux (VS_val_spec (typschm, id, ext, false), annot) - in - let simple_def = function - | DEF_spec vs -> DEF_spec (remove_cast_vs vs) - | def -> def - in - let is_overload = function - | DEF_overload _ -> true - | _ -> false - in - let defs = List.map simple_def defs in - Defs (List.filter (fun def -> not (is_overload def)) defs) - - -let rewrite_undefined mwords = - let rewrite_e_aux (E_aux (e_aux, _) as exp) = - match e_aux with - | E_lit (L_aux (L_undef, l)) -> - check_exp (env_of exp) (undefined_of_typ mwords l (fun _ -> ()) (Env.expand_synonyms (env_of exp) (typ_of exp))) (typ_of exp) - | _ -> exp - in - let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp_undefined) } - -let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) -and simple_typ_aux = function - | Typ_id id -> Typ_id id - | Typ_app (id, [_; _; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> - Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) - | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> - Typ_id (mk_id "int") - | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> - Typ_id (mk_id "int") - | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args)) - | Typ_fn (typ1, typ2, effs) -> Typ_fn (simple_typ typ1, simple_typ typ2, effs) - | Typ_tup typs -> Typ_tup (List.map simple_typ typs) - | Typ_exist (_, _, Typ_aux (typ, l)) -> simple_typ_aux typ - | typ_aux -> typ_aux -and simple_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = - match typ_arg_aux with - | Typ_arg_typ typ -> [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)] - | _ -> [] - -(* This pass aims to remove all the Num quantifiers from the specification. *) -let rewrite_simple_types (Defs defs) = - let is_simple = function - | QI_aux (QI_id kopt, annot) as qi when is_typ_kopt kopt || is_order_kopt kopt -> true - | _ -> false - in - let simple_typquant (TypQ_aux (tq_aux, annot)) = - match tq_aux with - | TypQ_no_forall -> TypQ_aux (TypQ_no_forall, annot) - | TypQ_tq quants -> TypQ_aux (TypQ_tq (List.filter (fun q -> is_simple q) quants), annot) - in - let simple_typschm (TypSchm_aux (TypSchm_ts (typq, typ), annot)) = - TypSchm_aux (TypSchm_ts (simple_typquant typq, simple_typ typ), annot) - in - let simple_vs (VS_aux (vs_aux, annot)) = - match vs_aux with - | VS_val_spec (typschm, id, ext, is_cast) -> VS_aux (VS_val_spec (simple_typschm typschm, id, ext, is_cast), annot) - in - let rec simple_lit (L_aux (lit_aux, l) as lit) = - match lit_aux with - | L_bin _ | L_hex _ -> - E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) - | _ -> E_lit lit - in - let simple_def = function - | DEF_spec vs -> DEF_spec (simple_vs vs) - | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant simple_typschm td) - | DEF_reg_dec ds -> DEF_reg_dec (rewrite_dec_spec_typs simple_typ ds) - | def -> def - in - let simple_pat = { - id_pat_alg with - p_typ = (fun (typ, pat) -> P_typ (simple_typ typ, pat)); - p_var = (fun (pat, kid) -> unaux_pat pat); - p_vector = (fun pats -> P_list pats) - } in - let simple_exp = { - id_exp_alg with - e_lit = simple_lit; - e_vector = (fun exps -> E_list exps); - e_cast = (fun (typ, exp) -> E_cast (simple_typ typ, exp)); - (* e_assert = (fun (E_aux (_, annot), str) -> E_assert (E_aux (E_lit (mk_lit L_true), annot), str)); *) - lEXP_cast = (fun (typ, lexp) -> LEXP_cast (simple_typ typ, lexp)); - pat_alg = simple_pat - } in - let simple_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp simple_exp); - rewrite_pat = (fun _ -> fold_pat simple_pat) } - in - let defs = Defs (List.map simple_def defs) in - rewrite_defs_base simple_defs defs - -let rewrite_tuple_vector_assignments defs = - let assign_tuple e_aux annot = - let env = env_of_annot annot in - match e_aux with - | E_assign (LEXP_aux (LEXP_tup lexps, lannot), exp) -> - let typ = Env.base_typ_of env (typ_of exp) in - if is_vector_typ typ then - (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) - let (start, _, ord, etyp) = vector_typ_args_of typ in - let len (LEXP_aux (le, lannot)) = - let ltyp = Env.base_typ_of env (typ_of_annot lannot) in - if is_vector_typ ltyp then - let (_, len, _, _) = vector_typ_args_of ltyp in - match nexp_simp len with - | Nexp_aux (Nexp_constant len, _) -> len - | _ -> unit_big_int - else unit_big_int in - let next i step = - if is_order_inc ord - then (sub_big_int (add_big_int i step) unit_big_int, add_big_int i step) - else (add_big_int (sub_big_int i step) unit_big_int, sub_big_int i step) in - let i = match nexp_simp start with - | (Nexp_aux (Nexp_constant i, _)) -> i - | _ -> if is_order_inc ord then zero_big_int else big_int_of_int (List.length lexps - 1) in - let l = gen_loc (fst annot) in - let exp' = - if small exp then strip_exp exp - else mk_exp (E_id (mk_id "split_vec")) in - let lexp_to_exp (i, exps) lexp = - let (j, i') = next i (len lexp) in - let i_exp = mk_exp (E_lit (mk_lit (L_num i))) in - let j_exp = mk_exp (E_lit (mk_lit (L_num j))) in - let sub = mk_exp (E_vector_subrange (exp', i_exp, j_exp)) in - (i', exps @ [sub]) in - let (_, exps) = List.fold_left lexp_to_exp (i, []) lexps in - let tup = mk_exp (E_tuple exps) in - let lexp = LEXP_aux (LEXP_tup (List.map strip_lexp lexps), (l, ())) in - let e_aux = - if small exp then mk_exp (E_assign (lexp, tup)) - else mk_exp ( - E_let ( - mk_letbind (mk_pat (P_id (mk_id "split_vec"))) (strip_exp exp), - mk_exp (E_assign (lexp, tup)))) in - begin - try check_exp env e_aux unit_typ with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err)) - end - else E_aux (e_aux, annot) - | _ -> E_aux (e_aux, annot) - in - let assign_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) - } in - let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in - rewrite_defs_base assign_defs defs - -let rewrite_tuple_assignments defs = - let assign_tuple e_aux annot = - let env = env_of_annot annot in - match e_aux with - | E_assign (LEXP_aux (LEXP_tup lexps, _), exp) -> - (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) - let (_, ids) = List.fold_left (fun (n, ids) _ -> (n + 1, ids @ [mk_id ("tup__" ^ string_of_int n)])) (0, []) lexps in - let block_assign i lexp = mk_exp (E_assign (strip_lexp lexp, mk_exp (E_id (mk_id ("tup__" ^ string_of_int i))))) in - let block = mk_exp (E_block (List.mapi block_assign lexps)) in - let letbind = mk_letbind (mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))) (strip_exp exp) in - let let_exp = mk_exp (E_let (letbind, block)) in - begin - try check_exp env let_exp unit_typ with - | Type_error (l, err) -> - raise (Reporting_basic.err_typ l (string_of_type_error err)) - end - | _ -> E_aux (e_aux, annot) - in - let assign_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) - } in - let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in - rewrite_defs_base assign_defs defs - -let rewrite_simple_assignments defs = - let assign_e_aux e_aux annot = - let env = env_of_annot annot in - match e_aux with - | E_assign (lexp, exp) -> - let (lexp, rhs) = rewrite_local_lexp lexp in - let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in - check_exp env assign unit_typ - | _ -> E_aux (e_aux, annot) - in - let assign_exp = { - id_exp_alg with - e_aux = (fun (e_aux, annot) -> assign_e_aux e_aux annot) - } in - let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in - rewrite_defs_base assign_defs defs - -let rewrite_defs_remove_blocks = - let letbind_wild v body = - let l = get_loc_exp v in - let env = env_of v in - let typ = typ_of v in - annot_exp (E_let (annot_letbind (P_wild, v) l env typ, body)) l env (typ_of body) in - (* let pat = annot_pat P_wild l env typ in - let (E_aux (_,(l,tannot))) = v in - let annot_pat = (simple_annot l (typ_of v)) in - let annot_lb = (gen_loc l, tannot) in - let annot_let = (gen_loc l, Some (env_of body, typ_of body, union_eff_exps [v;body])) in - E_aux (E_let (LB_aux (LB_val (P_aux (P_wild,annot_pat),v),annot_lb),body),annot_let) in *) - - let rec f l = function - | [] -> E_aux (E_lit (L_aux (L_unit,gen_loc l)), (simple_annot l unit_typ)) - | [e] -> e (* check with Kathy if that annotation is fine *) - | e :: es -> letbind_wild e (f l es) in - - let e_aux = function - | (E_block es,(l,_)) -> f l es - | (e,annot) -> E_aux (e,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - - rewrite_defs_base - {rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - - -let letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = - (* body is a function : E_id variable -> actual body *) - let (E_aux (_,(l,annot))) = v in - match annot with - | Some (env, Typ_aux (Typ_id tid, _), eff) when string_of_id tid = "unit" -> - let body = body (annot_exp (E_lit (mk_lit L_unit)) l env unit_typ) in - let body_typ = try typ_of body with _ -> unit_typ in - let lb = annot_letbind (P_wild, v) l env unit_typ in - propagate_exp_effect (annot_exp (E_let (lb, body)) l env body_typ) - | Some (env, typ, eff) -> - let id = fresh_id "w__" l in - let lb = annot_letbind (P_id id, v) l env typ in - let body = body (annot_exp (E_id id) l env typ) in - propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) - | None -> - raise (Reporting_basic.err_unreachable l "no type information") - - -let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = - match l with - | [] -> k [] - | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) - -let rewrite_defs_letbind_effects = - - let rec value ((E_aux (exp_aux,_)) as exp) = - not (effectful exp || updates_vars exp) - and value_optdefault (Def_val_aux (o,_)) = match o with - | Def_val_empty -> true - | Def_val_dec e -> value e - and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = - List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in - - - let rec n_exp_name (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - n_exp exp (fun exp -> if value exp then k exp else letbind exp k) - - and n_exp_pure (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - n_exp exp (fun exp -> if value exp then k exp else letbind exp k) - - and n_exp_nameL (exps : 'a exp list) (k : 'a exp list -> 'a exp) : 'a exp = - mapCont n_exp_name exps k - - and n_fexp (fexp : 'a fexp) (k : 'a fexp -> 'a exp) : 'a exp = - let (FE_aux (FE_Fexp (id,exp),annot)) = fexp in - n_exp_name exp (fun exp -> - k (fix_eff_fexp (FE_aux (FE_Fexp (id,exp),annot)))) - - and n_fexpL (fexps : 'a fexp list) (k : 'a fexp list -> 'a exp) : 'a exp = - mapCont n_fexp fexps k - - and n_pexp (newreturn : bool) (pexp : 'a pexp) (k : 'a pexp -> 'a exp) : 'a exp = - match pexp with - | Pat_aux (Pat_exp (pat,exp),annot) -> - k (fix_eff_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) - | Pat_aux (Pat_when (pat,guard,exp),annot) -> - k (fix_eff_pexp (Pat_aux (Pat_when (pat,n_exp_term newreturn guard,n_exp_term newreturn exp), annot))) - - and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = - mapCont (n_pexp newreturn) pexps k - - and n_fexps (fexps : 'a fexps) (k : 'a fexps -> 'a exp) : 'a exp = - let (FES_aux (FES_Fexps (fexps_aux,b),annot)) = fexps in - n_fexpL fexps_aux (fun fexps_aux -> - k (fix_eff_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) - - and n_opt_default (opt_default : 'a opt_default) (k : 'a opt_default -> 'a exp) : 'a exp = - let (Def_val_aux (opt_default,annot)) = opt_default in - match opt_default with - | Def_val_empty -> k (Def_val_aux (Def_val_empty,annot)) - | Def_val_dec exp -> - n_exp_name exp (fun exp -> - k (fix_eff_opt_default (Def_val_aux (Def_val_dec exp,annot)))) - - and n_lb (lb : 'a letbind) (k : 'a letbind -> 'a exp) : 'a exp = - let (LB_aux (lb,annot)) = lb in - match lb with - | LB_val (pat,exp1) -> - n_exp exp1 (fun exp1 -> - k (fix_eff_lb (LB_aux (LB_val (pat,exp1),annot)))) - - and n_lexp (lexp : 'a lexp) (k : 'a lexp -> 'a exp) : 'a exp = - let (LEXP_aux (lexp_aux,annot)) = lexp in - match lexp_aux with - | LEXP_id _ -> k lexp - | LEXP_memory (id,es) -> - n_exp_nameL es (fun es -> - k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) - | LEXP_tup es -> - n_lexpL es (fun es -> - k (fix_eff_lexp (LEXP_aux (LEXP_tup es,annot)))) - | LEXP_cast (typ,id) -> - k (fix_eff_lexp (LEXP_aux (LEXP_cast (typ,id),annot))) - | LEXP_vector (lexp,e) -> - n_lexp lexp (fun lexp -> - n_exp_name e (fun e -> - k (fix_eff_lexp (LEXP_aux (LEXP_vector (lexp,e),annot))))) - | LEXP_vector_range (lexp,e1,e2) -> - n_lexp lexp (fun lexp -> - n_exp_name e1 (fun e1 -> - n_exp_name e2 (fun e2 -> - k (fix_eff_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) - | LEXP_field (lexp,id) -> - n_lexp lexp (fun lexp -> - k (fix_eff_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) - - and n_lexpL (lexps : 'a lexp list) (k : 'a lexp list -> 'a exp) : 'a exp = - mapCont n_lexp lexps k - - and n_exp_term (newreturn : bool) (exp : 'a exp) : 'a exp = - let (E_aux (_,(l,tannot))) = exp in - let exp = - if newreturn then - (* let typ = try typ_of exp with _ -> unit_typ in *) - annot_exp (E_internal_return exp) l (env_of exp) (typ_of exp) - else - exp in - (* n_exp_term forces an expression to be translated into a form - "let .. let .. let .. in EXP" where EXP has no effect and does not update - variables *) - n_exp_pure exp (fun exp -> exp) - - and n_exp (E_aux (exp_aux,annot) as exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = - - let rewrap e = fix_eff_exp (E_aux (e,annot)) in - - match exp_aux with - | E_block es -> failwith "E_block should have been removed till now" - | E_nondet _ -> failwith "E_nondet not supported" - | E_id id -> k exp - | E_lit _ -> k exp - | E_cast (typ,exp') -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_cast (typ,exp')))) - | E_app (id,exps) -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_app (id,exps)))) - | E_app_infix (exp1,id,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_app_infix (exp1,id,exp2))))) - | E_tuple exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_tuple exps))) - | E_if (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - let (E_aux (_,annot2)) = exp2 in - let (E_aux (_,annot3)) = exp3 in - let newreturn = effectful exp2 || effectful exp3 in - let exp2 = n_exp_term newreturn exp2 in - let exp3 = n_exp_term newreturn exp3 in - k (rewrap (E_if (exp1,exp2,exp3)))) - | E_for (id,start,stop,by,dir,body) -> - n_exp_name start (fun start -> - n_exp_name stop (fun stop -> - n_exp_name by (fun by -> - let body = n_exp_term (effectful body) body in - k (rewrap (E_for (id,start,stop,by,dir,body)))))) - | E_loop (loop, cond, body) -> - let cond = n_exp_term (effectful cond) cond in - let body = n_exp_term (effectful body) body in - k (rewrap (E_loop (loop,cond,body))) - | E_vector exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_vector exps))) - | E_vector_access (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_vector_access (exp1,exp2))))) - | E_vector_subrange (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) - | E_vector_update (exp1,exp2,exp3) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - k (rewrap (E_vector_update (exp1,exp2,exp3)))))) - | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - n_exp_name exp3 (fun exp3 -> - n_exp_name exp4 (fun exp4 -> - k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) - | E_vector_append (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_vector_append (exp1,exp2))))) - | E_list exps -> - n_exp_nameL exps (fun exps -> - k (rewrap (E_list exps))) - | E_cons (exp1,exp2) -> - n_exp_name exp1 (fun exp1 -> - n_exp_name exp2 (fun exp2 -> - k (rewrap (E_cons (exp1,exp2))))) - | E_record fexps -> - n_fexps fexps (fun fexps -> - k (rewrap (E_record fexps))) - | E_record_update (exp1,fexps) -> - n_exp_name exp1 (fun exp1 -> - n_fexps fexps (fun fexps -> - k (rewrap (E_record_update (exp1,fexps))))) - | E_field (exp1,id) -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_field (exp1,id)))) - | E_case (exp1,pexps) -> - let newreturn = List.exists effectful_pexp pexps in - n_exp_name exp1 (fun exp1 -> - n_pexpL newreturn pexps (fun pexps -> - k (rewrap (E_case (exp1,pexps))))) - | E_let (lb,body) -> - n_lb lb (fun lb -> - rewrap (E_let (lb,n_exp body k))) - | E_sizeof nexp -> - k (rewrap (E_sizeof nexp)) - | E_constraint nc -> - k (rewrap (E_constraint nc)) - | E_sizeof_internal annot -> - k (rewrap (E_sizeof_internal annot)) - | E_assign (lexp,exp1) -> - n_lexp lexp (fun lexp -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_assign (lexp,exp1))))) - | E_exit exp' -> k (E_aux (E_exit (n_exp_term (effectful exp') exp'),annot)) - | E_assert (exp1,exp2) -> - n_exp exp1 (fun exp1 -> - n_exp exp2 (fun exp2 -> - k (rewrap (E_assert (exp1,exp2))))) - | E_internal_cast (annot',exp') -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_internal_cast (annot',exp')))) - | E_internal_exp _ -> k exp - | E_internal_exp_user _ -> k exp - | E_internal_let (lexp,exp1,exp2) -> - n_lexp lexp (fun lexp -> - n_exp exp1 (fun exp1 -> - rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) - | E_internal_return exp1 -> - n_exp_name exp1 (fun exp1 -> - k (rewrap (E_internal_return exp1))) - | E_comment str -> - k (rewrap (E_comment str)) - | E_comment_struc exp' -> - n_exp exp' (fun exp' -> - k (rewrap (E_comment_struc exp'))) - | E_return exp' -> - n_exp_name exp' (fun exp' -> - k (rewrap (E_return exp'))) - | E_internal_plet _ -> failwith "E_internal_plet should not be here yet" in - - let rewrite_fun _ (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),fdannot)) = - let effectful_funcl (FCL_aux (FCL_Funcl(_, _, exp), _)) = effectful exp in - let newreturn = List.exists effectful_funcl funcls in - let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),annot)) = - let _ = reset_fresh_name_counter () in - FCL_aux (FCL_Funcl (id,pat,n_exp_term newreturn exp),annot) - in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in - let rewrite_def rewriters def = - (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) - match def with - | DEF_val (LB_aux (lb, annot)) -> - let rewrap lb = DEF_val (LB_aux (lb, annot)) in - begin - match lb with - | LB_val (pat, exp) -> - rewrap (LB_val (pat, n_exp_term (effectful exp) exp)) - end - | DEF_fundef fdef -> DEF_fundef (rewrite_fun rewriters fdef) - | DEF_internal_mutrec fdefs -> - DEF_internal_mutrec (List.map (rewrite_fun rewriters) fdefs) - | d -> d in - rewrite_defs_base - {rewrite_exp = rewrite_exp - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - -let rewrite_defs_effectful_let_expressions = - - let rec pat_of_local_lexp (LEXP_aux (lexp, ((l, _) as annot))) = match lexp with - | LEXP_id id -> P_aux (P_id id, annot) - | LEXP_cast (typ, id) -> P_aux (P_typ (typ, P_aux (P_id id, annot)), annot) - | LEXP_tup lexps -> P_aux (P_tup (List.map pat_of_local_lexp lexps), annot) - | _ -> raise (Reporting_basic.err_unreachable l "unexpected local lexp") in - - let e_let (lb,body) = - match lb with - | LB_aux (LB_val (P_aux (P_wild, _), E_aux (E_assign ((LEXP_aux (_, annot) as le), exp), _)), _) - when lexp_is_local le (env_of_annot annot) && not (lexp_is_effectful le) -> - (* Rewrite assignments to local variables into let bindings *) - let (lhs, rhs) = rewrite_local_lexp le in - E_let (LB_aux (LB_val (pat_of_local_lexp lhs, rhs exp), annot), body) - | LB_aux (LB_val (pat,exp'),annot') -> - if effectful exp' - then E_internal_plet (pat,exp',body) - else E_let (lb,body) in - - let e_internal_let = fun (lexp,exp1,exp2) -> - match lexp with - | LEXP_aux (LEXP_id id,annot) - | LEXP_aux (LEXP_cast (_,id),annot) -> - if effectful exp1 then - E_internal_plet (P_aux (P_id id,annot),exp1,exp2) - else - let lb = LB_aux (LB_val (P_aux (P_id id,annot), exp1), annot) in - E_let (lb, exp2) - | _ -> failwith "E_internal_let with unexpected lexp" in - - let alg = { id_exp_alg with e_let = e_let; e_internal_let = e_internal_let } in - rewrite_defs_base - { rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -(* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, - * internal let-expressions, or internal plet-expressions ended by a term that does not - * access memory or registers and does not update variables *) - -let dedup eq = - List.fold_left (fun acc e -> if List.exists (eq e) acc then acc else e :: acc) [] - -let eqidtyp (id1,_) (id2,_) = - let name1 = match id1 with Id_aux ((Id name | DeIid name),_) -> name in - let name2 = match id2 with Id_aux ((Id name | DeIid name),_) -> name in - name1 = name2 - -let find_introduced_vars exp = - let e_aux ((ids,e_aux),annot) = - let ids = match e_aux, annot with - | E_internal_let (LEXP_aux (LEXP_id id, _), _, _), (_, Some (env, _, _)) - | E_internal_let (LEXP_aux (LEXP_cast (_, id), _), _, _), (_, Some (env, _, _)) - when id_is_unbound id env -> IdSet.add id ids - | _ -> ids in - (ids, E_aux (e_aux, annot)) in - fst (fold_exp - { (compute_exp_alg IdSet.empty IdSet.union) with e_aux = e_aux } exp) - -let find_updated_vars exp = - let intros = find_introduced_vars exp in - let e_aux ((ids,e_aux),annot) = - let ids = match e_aux, annot with - | E_assign (LEXP_aux (LEXP_id id, _), _), (_, Some (env, _, _)) - | E_assign (LEXP_aux (LEXP_cast (_, id), _), _), (_, Some (env, _, _)) - when id_is_local_var id env && not (IdSet.mem id intros) -> - (id, annot) :: ids - | _ -> ids in - (ids, E_aux (e_aux, annot)) in - dedup eqidtyp (fst (fold_exp - { (compute_exp_alg [] (@)) with e_aux = e_aux } exp)) - -let swaptyp typ (l,tannot) = match tannot with - | Some (env, typ', eff) -> (l, Some (env, typ, eff)) - | _ -> raise (Reporting_basic.err_unreachable l "swaptyp called with empty type annotation") - -let mktup l es = - match es with - | [] -> annot_exp (E_lit (mk_lit L_unit)) (gen_loc l) Env.empty unit_typ - | [e] -> e - | e :: _ -> - let typ = mk_typ (Typ_tup (List.map typ_of es)) in - propagate_exp_effect (annot_exp (E_tuple es) (gen_loc l) (env_of e) typ) - -let mktup_pat l es = - match es with - | [] -> annot_pat P_wild (gen_loc l) Env.empty unit_typ - | [E_aux (E_id id,_) as exp] -> - annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) - | exp :: _ -> - let typ = mk_typ (Typ_tup (List.map typ_of es)) in - let pats = List.map (function - | (E_aux (E_id id,_) as exp) -> - annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) - | exp -> - annot_pat P_wild (gen_loc l) (env_of exp) (typ_of exp)) es in - annot_pat (P_tup pats) (gen_loc l) (env_of exp) typ - - -type 'a updated_term = - | Added_vars of 'a exp * 'a pat - | Same_vars of 'a exp - -let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = - - let env = env_of exp in - - let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = - match expaux with - | E_let (lb,exp) -> - let exp = add_vars overwrite exp vars in - E_aux (E_let (lb,exp),swaptyp (typ_of exp) annot) - | E_internal_let (lexp,exp1,exp2) -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) - | E_internal_plet (pat,exp1,exp2) -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (typ_of exp2) annot) - | E_internal_return exp2 -> - let exp2 = add_vars overwrite exp2 vars in - E_aux (E_internal_return exp2,swaptyp (typ_of exp2) annot) - | _ -> - (* after rewrite_defs_letbind_effects there cannot be terms that have - effects/update local variables in "tail-position": check n_exp_term - and where it is used. *) - if overwrite then - match typ_of exp with - | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> vars - | _ -> raise (Reporting_basic.err_unreachable l - "add_vars: trying to overwrite a non-unit expression in tail-position") - else - let typ' = Typ_aux (Typ_tup [typ_of exp;typ_of vars], gen_loc l) in - E_aux (E_tuple [exp;vars],swaptyp typ' annot) in - - let rewrite (E_aux (expaux,((el,_) as annot))) (P_aux (_,(pl,pannot)) as pat) = - let overwrite = match typ_of_annot annot with - | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true - | _ -> false in - match expaux with - | E_for(id,exp1,exp2,exp3,order,exp4) -> - (* Translate for loops into calls to one of the foreach combinators. - The loop body becomes a function of the loop variable and any - mutable local variables that are updated inside the loop. - Since the foreach* combinators are higher-order functions, - they cannot be represented faithfully in the AST. The following - code abuses the parameters of an E_app node, embedding the loop body - function as an expression followed by the list of variables it - expects. In (Lem) pretty-printing, this turned into an anonymous - function and passed to foreach*. *) - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars exp4) in - let vartuple = mktup el vars in - let exp4 = rewrite_var_updates (add_vars overwrite exp4 vartuple) in - let (E_aux (_,(_,annot4))) = exp4 in - let fname = match effectful exp4,order with - | false, Ord_aux (Ord_inc,_) -> "foreach_inc" - | false, Ord_aux (Ord_dec,_) -> "foreach_dec" - | true, Ord_aux (Ord_inc,_) -> "foreachM_inc" - | true, Ord_aux (Ord_dec,_) -> "foreachM_dec" - | _ -> raise (Reporting_basic.err_unreachable el - "Could not determine foreach combinator") in - let funcl = Id_aux (Id fname,gen_loc el) in - let loopvar = - (* Don't bother with creating a range type annotation, since the - Lem pretty-printing does not use it. *) - (* let (bf,tf) = match typ_of exp1 with - | {t = Tapp ("atom",[TA_nexp f])} -> (TA_nexp f,TA_nexp f) - | {t = Tapp ("reg", [TA_typ {t = Tapp ("atom",[TA_nexp f])}])} -> (TA_nexp f,TA_nexp f) - | {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])} -> (TA_nexp bf,TA_nexp tf) - | {t = Tapp ("reg", [TA_typ {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])}])} -> (TA_nexp bf,TA_nexp tf) - | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in - let (bt,tt) = match typ_of exp2 with - | {t = Tapp ("atom",[TA_nexp t])} -> (TA_nexp t,TA_nexp t) - | {t = Tapp ("atom",[TA_typ {t = Tapp ("atom", [TA_nexp t])}])} -> (TA_nexp t,TA_nexp t) - | {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])} -> (TA_nexp bt,TA_nexp tt) - | {t = Tapp ("atom",[TA_typ {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])}])} -> (TA_nexp bt,TA_nexp tt) - | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in - let t = {t = Tapp ("range",match order with - | Ord_aux (Ord_inc,_) -> [bf;tt] - | Ord_aux (Ord_dec,_) -> [tf;bt])} in *) - annot_exp (E_id id) l env int_typ in - let v = E_aux (E_app (funcl,[loopvar;mktup el [exp1;exp2;exp3];exp4;vartuple]), - (gen_loc el, annot4)) in - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_loop(loop,cond,body) -> - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars body) in - let vartuple = mktup el vars in - (* let cond = rewrite_var_updates (add_vars false cond vartuple) in *) - let body = rewrite_var_updates (add_vars overwrite body vartuple) in - let (E_aux (_,(_,bannot))) = body in - let fname = match loop, effectful cond, effectful body with - | While, false, false -> "while_PP" - | While, false, true -> "while_PM" - | While, true, false -> "while_MP" - | While, true, true -> "while_MM" - | Until, false, false -> "until_PP" - | Until, false, true -> "until_PM" - | Until, true, false -> "until_MP" - | Until, true, true -> "until_MM" in - let funcl = Id_aux (Id fname,gen_loc el) in - let v = E_aux (E_app (funcl,[cond;body;vartuple]), (gen_loc el, bannot)) in - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_if (c,e1,e2) -> - let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) - (dedup eqidtyp (find_updated_vars e1 @ find_updated_vars e2)) in - if vars = [] then - (Same_vars (E_aux (E_if (c,rewrite_var_updates e1,rewrite_var_updates e2),annot))) - else - let vartuple = mktup el vars in - let e1 = rewrite_var_updates (add_vars overwrite e1 vartuple) in - let e2 = rewrite_var_updates (add_vars overwrite e2 vartuple) in - (* after rewrite_defs_letbind_effects c has no variable updates *) - let env = env_of_annot annot in - let typ = typ_of e1 in - let eff = union_eff_exps [e1;e2] in - let v = E_aux (E_if (c,e1,e2), (gen_loc el, Some (env, typ, eff))) in - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_case (e1,ps) -> - (* after rewrite_defs_letbind_effects e1 needs no rewriting *) - let vars = - let f acc (Pat_aux ((Pat_exp (_,e)|Pat_when (_,_,e)),_)) = - acc @ find_updated_vars e in - List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) - (dedup eqidtyp (List.fold_left f [] ps)) in - if vars = [] then - let ps = List.map (function - | Pat_aux (Pat_exp (p,e),a) -> - Pat_aux (Pat_exp (p,rewrite_var_updates e),a) - | Pat_aux (Pat_when (p,g,e),a) -> - Pat_aux (Pat_when (p,g,rewrite_var_updates e),a)) ps in - Same_vars (E_aux (E_case (e1,ps),annot)) - else - let vartuple = mktup el vars in - let rewrite_pexp (Pat_aux (pexp, (l, _))) = match pexp with - | Pat_exp (pat, exp) -> - let exp = rewrite_var_updates (add_vars overwrite exp vartuple) in - let pannot = (l, Some (env_of exp, typ_of exp, effect_of exp)) in - Pat_aux (Pat_exp (pat, exp), pannot) - | Pat_when _ -> - raise (Reporting_basic.err_unreachable l - "Guarded patterns should have been rewritten already") in - let typ = match ps with - | Pat_aux ((Pat_exp (_,first)|Pat_when (_,_,first)),_) :: _ -> typ_of first - | _ -> unit_typ in - let v = propagate_exp_effect (annot_exp (E_case (e1, List.map rewrite_pexp ps)) pl env typ) in - (* let (ps,typ,effs) = - let f (acc,typ,effs) (Pat_aux (Pat_exp (p,e),pannot)) = - let etyp = typ_of e in - let () = assert (string_of_typ etyp = string_of_typ typ) in - let e = rewrite_var_updates (add_vars overwrite e vartuple) in - let pannot = simple_annot pl (typ_of e) in - let effs = union_effects effs (effect_of e) in - let pat' = Pat_aux (Pat_exp (p,e),pannot) in - (acc @ [pat'],typ,effs) in - List.fold_left f ([],typ,no_effect) ps in - let v = E_aux (E_case (e1,ps), (gen_loc pl, Some (env_of_annot annot, typ, effs))) in *) - let pat = - if overwrite then mktup_pat el vars - else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in - Added_vars (v,pat) - | E_assign (lexp,vexp) -> - let effs = match effect_of_annot (snd annot) with - | Effect_aux (Effect_set effs, _) -> effs - | _ -> - raise (Reporting_basic.err_unreachable l - "assignment without effects annotation") in - if effectful exp then - Same_vars (E_aux (E_assign (lexp,vexp),annot)) - else - (match lexp with - | LEXP_aux (LEXP_id id,annot) -> - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | LEXP_aux (LEXP_cast (_,id),annot) -> - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | LEXP_aux (LEXP_vector (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i),((l1,_) as annot)) -> - let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in - let vexp = annot_exp (E_vector_update (eid,i,vexp)) l1 env (typ_of_annot annot) in - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i,j), - ((l,_) as annot)) -> - let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in - let vexp = annot_exp (E_vector_update_subrange (eid,i,j,vexp)) l env (typ_of_annot annot) in - let pat = annot_pat (P_id id) pl env (typ_of vexp) in - Added_vars (vexp,pat) - | _ -> Same_vars (E_aux (E_assign (lexp,vexp),annot))) - | _ -> - (* after rewrite_defs_letbind_effects this expression is pure and updates - no variables: check n_exp_term and where it's used. *) - Same_vars (E_aux (expaux,annot)) in - - match expaux with - | E_let (lb,body) -> - let body = rewrite_var_updates body in - let (LB_aux (LB_val (pat, v), lbannot)) = lb in - let lb = match rewrite v pat with - | Added_vars (v, P_aux (pat, _)) -> - annot_letbind (pat, v) (get_loc_exp v) env (typ_of v) - | Same_vars v -> LB_aux (LB_val (pat, v),lbannot) in - propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) - | E_internal_let (lexp,v,body) -> - (* Rewrite E_internal_let into E_let and call recursively *) - let id = match lexp with - | LEXP_aux (LEXP_id id,_) -> id - | LEXP_aux (LEXP_cast (_,id),_) -> id - | _ -> - raise (Reporting_basic.err_unreachable l - "E_internal_let with a lexp that is not a variable") in - let pat = annot_pat (P_id id) l env (typ_of v) in - let lb = annot_letbind (P_id id, v) l env (typ_of v) in - let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in - rewrite_var_updates exp - (* let env = env_of_annot annot in - let vtyp = typ_of v in - let veff = effect_of v in - let bodyenv = env_of body in - let bodytyp = typ_of body in - let bodyeff = effect_of body in - let pat = P_aux (P_id id, (simple_annot l vtyp)) in - let lbannot = (gen_loc l, Some (env, vtyp, veff)) in - let lb = LB_aux (LB_val (pat,v),lbannot) in - let exp = E_aux (E_let (lb,body),(gen_loc l, Some (bodyenv, bodytyp, union_effects veff bodyeff))) in - rewrite_var_updates exp *) - | E_internal_plet (pat,v,body) -> - failwith "rewrite_var_updates: E_internal_plet shouldn't be introduced yet" - (* There are no expressions that have effects or variable updates in - "tail-position": check the definition nexp_term and where it is used. *) - | _ -> exp - -let replace_memwrite_e_assign exp = - let e_aux = fun (expaux,annot) -> - match expaux with - | E_assign (LEXP_aux (LEXP_memory (id,args),_),v) -> E_aux (E_app (id,args @ [v]),annot) - | _ -> E_aux (expaux,annot) in - fold_exp { id_exp_alg with e_aux = e_aux } exp - - - -let remove_reference_types exp = - - let rec rewrite_t (Typ_aux (t_aux,a)) = (Typ_aux (rewrite_t_aux t_aux,a)) - and rewrite_t_aux t_aux = match t_aux with - | Typ_app (Id_aux (Id "reg",_), [Typ_arg_aux (Typ_arg_typ (Typ_aux (t_aux2, _)), _)]) -> - rewrite_t_aux t_aux2 - | Typ_app (name,t_args) -> Typ_app (name,List.map rewrite_t_arg t_args) - | Typ_fn (t1,t2,eff) -> Typ_fn (rewrite_t t1,rewrite_t t2,eff) - | Typ_tup ts -> Typ_tup (List.map rewrite_t ts) - | _ -> t_aux - and rewrite_t_arg t_arg = match t_arg with - | Typ_arg_aux (Typ_arg_typ t, a) -> Typ_arg_aux (Typ_arg_typ (rewrite_t t), a) - | _ -> t_arg in - - let rec rewrite_annot = function - | (l, None) -> (l, None) - | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_t typ, eff)) in - - map_exp_annot rewrite_annot exp - - - -let rewrite_defs_remove_superfluous_letbinds = - - let e_aux (exp,annot) = match exp with - | E_let (lb,exp2) -> - begin match lb,exp2 with - (* 'let x = EXP1 in x' can be replaced with 'EXP1' *) - | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_id (Id_aux (id',_)),_) - | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' -> - exp1 - (* "let x = EXP1 in return x" can be replaced with 'return (EXP1)', at - least when EXP1 is 'small' enough *) - | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' && small exp1 -> - let (E_aux (_,e1annot)) = exp1 in - E_aux (E_internal_return (exp1),e1annot) - | _ -> E_aux (exp,annot) - end - | _ -> E_aux (exp,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - rewrite_defs_base - { rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -let rewrite_defs_remove_superfluous_returns = - - let has_unittype e = match typ_of e with - | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true - | _ -> false in - - let e_aux (exp,annot) = match exp with - | E_internal_plet (pat,exp1,exp2) when effectful exp1 -> - begin match pat,exp2 with - | P_aux (P_lit (L_aux (lit,_)),_), - E_aux (E_internal_return (E_aux (E_lit (L_aux (lit',_)),_)),_) - when lit = lit' -> - exp1 - | P_aux (P_wild,pannot), - E_aux (E_internal_return (E_aux (E_lit (L_aux (L_unit,_)),_)),_) - when has_unittype exp1 -> - exp1 - | P_aux (P_id (Id_aux (id,_)),_), - E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) - when id = id' -> - exp1 - | _ -> E_aux (exp,annot) - end - | _ -> E_aux (exp,annot) in - - let alg = { id_exp_alg with e_aux = e_aux } in - rewrite_defs_base - { rewrite_exp = (fun _ -> fold_exp alg) - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - - -let rewrite_defs_remove_e_assign = - let rewrite_exp _ e = - replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in - rewrite_defs_base - { rewrite_exp = rewrite_exp - ; rewrite_pat = rewrite_pat - ; rewrite_let = rewrite_let - ; rewrite_lexp = rewrite_lexp - ; rewrite_fun = rewrite_fun - ; rewrite_def = rewrite_def - ; rewrite_defs = rewrite_defs_base - } - -let recheck_defs defs = fst (check initial_env defs) - -let rewrite_defs_lem = [ - ("top_sort_defs", top_sort_defs); - ("tuple_vector_assignments", rewrite_tuple_vector_assignments); - ("tuple_assignments", rewrite_tuple_assignments); - (* ("simple_assignments", rewrite_simple_assignments); *) - ("constraint", rewrite_constraint); - ("trivial_sizeof", rewrite_trivial_sizeof); - ("sizeof", rewrite_sizeof); - ("remove_vector_concat", rewrite_defs_remove_vector_concat); - ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); - ("guarded_pats", rewrite_defs_guarded_pats); - (* ("recheck_defs", recheck_defs); *) - ("early_return", rewrite_defs_early_return); - ("nexp_ids", rewrite_defs_nexp_ids); - ("fix_val_specs", rewrite_fix_val_specs); - ("exp_lift_assign", rewrite_defs_exp_lift_assign); - ("remove_blocks", rewrite_defs_remove_blocks); - ("letbind_effects", rewrite_defs_letbind_effects); - ("remove_e_assign", rewrite_defs_remove_e_assign); - ("effectful_let_expressions", rewrite_defs_effectful_let_expressions); - ("remove_superfluous_letbinds", rewrite_defs_remove_superfluous_letbinds); - ("remove_superfluous_returns", rewrite_defs_remove_superfluous_returns) - ] - -let rewrite_defs_ocaml = [ - (* ("top_sort_defs", top_sort_defs); *) - (* ("undefined", rewrite_undefined); *) - ("tuple_vector_assignments", rewrite_tuple_vector_assignments); - ("tuple_assignments", rewrite_tuple_assignments); - ("simple_assignments", rewrite_simple_assignments); - ("remove_vector_concat", rewrite_defs_remove_vector_concat); - ("constraint", rewrite_constraint); - ("trivial_sizeof", rewrite_trivial_sizeof); - ("sizeof", rewrite_sizeof); - ("simple_types", rewrite_simple_types); - ("overload_cast", rewrite_overload_cast); - ("exp_lift_assign", rewrite_defs_exp_lift_assign); - (* ("separate_numbs", rewrite_defs_separate_numbs) *) - ] - -let rewrite_check_annot = - let check_annot exp = - try - prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); - let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in - exp - with - Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) - in - let rewrite_exp = { id_exp_alg with e_aux = (fun (exp, annot) -> check_annot (E_aux (exp, annot))) } in - rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp) } - -let rewrite_defs_check = [ - ("check_annotations", rewrite_check_annot); - ] diff --git a/src/rewriter.mli b/src/rewriter.mli index c107be25..514ed034 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -55,13 +55,23 @@ type 'a rewriters = { rewrite_exp : 'a rewriters -> 'a exp -> 'a exp; } val rewrite_exp : tannot rewriters -> tannot exp -> tannot exp + +val rewriters_base : tannot rewriters + +(* The identity re-writer *) val rewrite_defs : tannot defs -> tannot defs -val rewrite_undefined : bool -> tannot defs -> tannot defs -val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list (*Perform rewrites to exclude AST nodes not supported for ocaml out*) -val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list (*Perform rewrites to exclude AST nodes not supported for lem out*) -val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list -val simple_typ : typ -> typ +val rewrite_defs_base : tannot rewriters -> tannot defs -> tannot defs + +val rewrite_lexp : tannot rewriters -> tannot lexp -> tannot lexp + +val rewrite_pat : tannot rewriters -> tannot pat -> tannot pat + +val rewrite_let : tannot rewriters -> tannot letbind -> tannot letbind + +val rewrite_def : tannot rewriters -> tannot def -> tannot def + +val rewrite_fun : tannot rewriters -> tannot fundef -> tannot fundef (* the type of interpretations of pattern-matching expressions *) type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = @@ -82,10 +92,8 @@ type ('a,'pat,'pat_aux,'fpat,'fpat_aux) pat_alg = ; fP_aux : 'fpat_aux * 'a annot -> 'fpat ; fP_Fpat : id * 'pat -> 'fpat_aux } - (* fold over pat_aux expressions *) - (* the type of interpretations of expressions *) type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, 'opt_default_aux,'opt_default,'pexp,'pexp_aux,'letbind_aux,'letbind, @@ -177,3 +185,24 @@ val compute_exp_alg : 'b -> ('b -> 'b -> 'b) -> ('b * 'a opt_default_aux),('b * 'a opt_default),('b * 'a pexp),('b * 'a pexp_aux), ('b * 'a letbind_aux),('b * 'a letbind), ('b * 'a pat),('b * 'a pat_aux),('b * 'a fpat),('b * 'a fpat_aux)) exp_alg + +val simple_annot : Parse_ast.l -> typ -> Parse_ast.l * tannot + +val union_eff_exps : (tannot exp) list -> effect + +val fix_eff_exp : tannot exp -> tannot exp + +val fix_eff_lexp : tannot lexp -> tannot lexp + +val fix_eff_lb : tannot letbind -> tannot letbind + +val fix_eff_pexp : tannot pexp -> tannot pexp + +val fix_eff_fexp : tannot fexp -> tannot fexp + +val fix_eff_fexps : tannot fexps -> tannot fexps + +val fix_eff_opt_default : tannot opt_default -> tannot opt_default + +(* AA: How this is used in rewrite_pat seems suspect to me *) +val vector_string_to_bit_list : Parse_ast.l -> lit_aux -> lit list diff --git a/src/rewrites.ml b/src/rewrites.ml new file mode 100644 index 00000000..74f252f4 --- /dev/null +++ b/src/rewrites.ml @@ -0,0 +1,2767 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Thomas Bauereiss *) +(* *) +(* 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 Big_int +open Ast +open Ast_util +open Type_check +open Spec_analysis +open Rewriter + +let (>>) f g = fun x -> g(f(x)) + +let fresh_name_counter = ref 0 + +let fresh_name () = + let current = !fresh_name_counter in + let () = fresh_name_counter := (current + 1) in + current + +let reset_fresh_name_counter () = + fresh_name_counter := 0 + +let fresh_id pre l = + let current = fresh_name () in + Id_aux (Id (pre ^ string_of_int current), gen_loc l) + +let fresh_id_exp pre ((l,annot)) = + let id = fresh_id pre l in + E_aux (E_id id, (gen_loc l, annot)) + +let fresh_id_pat pre ((l,annot)) = + let id = fresh_id pre l in + P_aux (P_id id, (gen_loc l, annot)) + +let get_loc_exp (E_aux (_,(l,_))) = l + +let annot_exp_effect e_aux l env typ effect = E_aux (e_aux, (l, Some (env, typ, effect))) +let annot_exp e_aux l env typ = annot_exp_effect e_aux l env typ no_effect +let annot_pat p_aux l env typ = P_aux (p_aux, (l, Some (env, typ, no_effect))) +let annot_letbind (p_aux, exp) l env typ = + LB_aux (LB_val (annot_pat p_aux l env typ, exp), (l, Some (env, typ, effect_of exp))) + +let simple_num l n = E_aux ( + E_lit (L_aux (L_num n, gen_loc l)), + simple_annot (gen_loc l) + (atom_typ (Nexp_aux (Nexp_constant n, gen_loc l)))) + +let effectful_effs = function + | Effect_aux (Effect_set effs, _) -> + List.exists + (fun (BE_aux (be,_)) -> + match be with + | BE_nondet | BE_unspec | BE_undef | BE_lset -> false + | _ -> true + ) effs + | _ -> true + +let effectful eaux = effectful_effs (effect_of (propagate_exp_effect eaux)) +let effectful_pexp pexp = effectful_effs (snd (propagate_pexp_effect pexp)) + +let updates_vars_effs = function + | Effect_aux (Effect_set effs, _) -> + List.exists + (fun (BE_aux (be,_)) -> + match be with + | BE_lset -> true + | _ -> false + ) effs + | _ -> true + +let updates_vars eaux = updates_vars_effs (effect_of eaux) + +let rec small (E_aux (exp,_)) = match exp with + | E_id _ + | E_lit _ -> true + | E_cast (_,e) -> small e + | E_list es -> List.for_all small es + | E_cons (e1,e2) -> small e1 && small e2 + | E_sizeof _ -> true + | _ -> false + +let rec rewrite_nexp_ids env (Nexp_aux (nexp, l) as nexp_aux) = match nexp with +| Nexp_id id -> rewrite_nexp_ids env (Env.get_num_def id env) +| Nexp_times (nexp1, nexp2) -> Nexp_aux (Nexp_times (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_sum (nexp1, nexp2) -> Nexp_aux (Nexp_sum (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_minus (nexp1, nexp2) -> Nexp_aux (Nexp_minus (rewrite_nexp_ids env nexp1, rewrite_nexp_ids env nexp2), l) +| Nexp_exp nexp -> Nexp_aux (Nexp_exp (rewrite_nexp_ids env nexp), l) +| Nexp_neg nexp -> Nexp_aux (Nexp_neg (rewrite_nexp_ids env nexp), l) +| _ -> nexp_aux + +let rewrite_defs_nexp_ids, rewrite_typ_nexp_ids = + let rec rewrite_typ env (Typ_aux (typ, l) as typ_aux) = match typ with + | Typ_fn (arg_t, ret_t, eff) -> + Typ_aux (Typ_fn (rewrite_typ env arg_t, rewrite_typ env ret_t, eff), l) + | Typ_tup ts -> + Typ_aux (Typ_tup (List.map (rewrite_typ env) ts), l) + | Typ_exist (kids, c, typ) -> + Typ_aux (Typ_exist (kids, c, rewrite_typ env typ), l) + | Typ_app (id, targs) -> + Typ_aux (Typ_app (id, List.map (rewrite_typ_arg env) targs), l) + | _ -> typ_aux + and rewrite_typ_arg env (Typ_arg_aux (targ, l) as targ_aux) = match targ with + | Typ_arg_nexp nexp -> + Typ_arg_aux (Typ_arg_nexp (rewrite_nexp_ids env nexp), l) + | Typ_arg_typ typ -> + Typ_arg_aux (Typ_arg_typ (rewrite_typ env typ), l) + | Typ_arg_order ord -> + Typ_arg_aux (Typ_arg_order ord, l) + in + + let rewrite_annot = function + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_typ env typ, eff)) + | (l, None) -> (l, None) + in + + rewrite_defs_base { + rewriters_base with rewrite_exp = (fun _ -> map_exp_annot rewrite_annot) + }, + rewrite_typ + + +(* Re-write trivial sizeof expressions - trivial meaning that the + value of the sizeof can be directly inferred from the type + variables in scope. *) +let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = + let extract_typ_var l env nexp (id, (_, typ)) = + let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in + match destruct_atom_nexp env typ with + | Some size when prove env (nc_eq size nexp) -> Some var + | _ -> + begin + match destruct_vector env typ with + | Some (_, len, _, _) when prove env (nc_eq len nexp) -> + Some (E_aux (E_app (mk_id "length", [var]), (l, Some (env, atom_typ len, no_effect)))) + | _ -> None + end + in + let rec split_nexp (Nexp_aux (nexp_aux, l) as nexp) = + match nexp_aux with + | Nexp_sum (n1, n2) -> + mk_exp (E_app (mk_id "add_range", [split_nexp n1; split_nexp n2])) + | Nexp_minus (n1, n2) -> + mk_exp (E_app (mk_id "sub_range", [split_nexp n1; split_nexp n2])) + | Nexp_times (n1, n2) -> + mk_exp (E_app (mk_id "mult_range", [split_nexp n1; split_nexp n2])) + | Nexp_neg nexp -> mk_exp (E_app (mk_id "negate_range", [split_nexp nexp])) + | _ -> mk_exp (E_sizeof nexp) + in + let rec rewrite_e_aux split_sizeof (E_aux (e_aux, (l, _)) as orig_exp) = + let env = env_of orig_exp in + match e_aux with + | E_sizeof (Nexp_aux (Nexp_constant c, _) as nexp) -> + E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) + | E_sizeof nexp -> + begin + match nexp_simp (rewrite_nexp_ids (env_of orig_exp) nexp) with + | Nexp_aux (Nexp_constant c, _) -> + E_aux (E_lit (L_aux (L_num c, l)), (l, Some (env, atom_typ nexp, no_effect))) + | _ -> + let locals = Env.get_locals env in + let exps = Bindings.bindings locals + |> List.map (extract_typ_var l env nexp) + |> List.map (fun opt -> match opt with Some x -> [x] | None -> []) + |> List.concat + in + match exps with + | (exp :: _) -> check_exp env (strip_exp exp) (typ_of exp) + | [] when split_sizeof -> + fold_exp (rewrite_e_sizeof false) (check_exp env (split_nexp nexp) (typ_of orig_exp)) + | [] -> orig_exp + end + | _ -> orig_exp + and rewrite_e_sizeof split_sizeof = + { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux split_sizeof (E_aux (exp, annot))) } + in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp (rewrite_e_sizeof true)) }, rewrite_e_aux true + +(* Rewrite sizeof expressions with type-level variables to + term-level expressions + + For each type-level variable used in a sizeof expressions whose value cannot + be directly extracted from existing parameters of the surrounding function, + a further parameter is added; calls to the function are rewritten + accordingly (possibly causing further rewriting in the calling function) *) +let rewrite_sizeof (Defs defs) = + let sizeof_frees exp = + fst (fold_exp + { (compute_exp_alg KidSet.empty KidSet.union) with + e_sizeof = (fun nexp -> (nexp_frees nexp, E_sizeof nexp)) } + exp) in + + (* Collect nexps whose values can be obtained directly from a pattern bind *) + let nexps_from_params pat = + fst (fold_pat + { (compute_pat_alg [] (@)) with + p_aux = (fun ((v,pat),((l,_) as annot)) -> + let v' = match pat with + | P_id id | P_as (_, id) -> + let (Typ_aux (typ,_) as typ_aux) = typ_of_annot annot in + (match typ with + | Typ_app (atom, [Typ_arg_aux (Typ_arg_nexp nexp, _)]) + when string_of_id atom = "atom" -> + [nexp, E_id id] + | Typ_app (vector, _) when string_of_id vector = "vector" -> + let id_length = Id_aux (Id "length", gen_loc l) in + (try + (match Env.get_val_spec id_length (env_of_annot annot) with + | _ -> + let (_,len,_,_) = vector_typ_args_of typ_aux in + let exp = E_app (id_length, [E_aux (E_id id, annot)]) in + [len, exp]) + with + | _ -> []) + | _ -> []) + | _ -> [] in + (v @ v', P_aux (pat,annot)))} pat) in + + (* Substitute collected values in sizeof expressions *) + let rec e_sizeof nmap (Nexp_aux (nexp, l) as nexp_aux) = + try snd (List.find (fun (nexp,_) -> nexp_identical nexp nexp_aux) nmap) + with + | Not_found -> + let binop nexp1 op nexp2 = E_app_infix ( + E_aux (e_sizeof nmap nexp1, simple_annot l (atom_typ nexp1)), + Id_aux (Id op, Parse_ast.Unknown), + E_aux (e_sizeof nmap nexp2, simple_annot l (atom_typ nexp2)) + ) in + let (Nexp_aux (nexp, l) as nexp_aux) = nexp_simp nexp_aux in + (match nexp with + | Nexp_constant i -> E_lit (L_aux (L_num i, l)) + | Nexp_times (nexp1, nexp2) -> binop nexp1 "*" nexp2 + | Nexp_sum (nexp1, nexp2) -> binop nexp1 "+" nexp2 + | Nexp_minus (nexp1, nexp2) -> binop nexp1 "-" nexp2 + | _ -> E_sizeof nexp_aux) in + + let ex_regex = Str.regexp "'ex[0-9]+" in + + (* Rewrite calls to functions which have had parameters added to pass values + of type-level variables; these are added as sizeof expressions first, and + then further rewritten as above. *) + let e_app_aux param_map ((exp, exp_orig), ((l, _) as annot)) = + let env = env_of_annot annot in + let full_exp = E_aux (exp, annot) in + let orig_exp = E_aux (exp_orig, annot) in + match exp with + | E_app (f, args) -> + if Bindings.mem f param_map then + (* Retrieve instantiation of the type variables of the called function + for the given parameters in the original environment *) + let inst = + try instantiation_of orig_exp with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) in + (* Rewrite the inst using orig_kid so that each type variable has it's + original name rather than a mangled typechecker name *) + let inst = KBindings.fold (fun kid uvar b -> KBindings.add (orig_kid kid) uvar b) inst KBindings.empty in + let kid_exp kid = begin + (* We really don't want to see an existential here! *) + assert (not (Str.string_match ex_regex (string_of_kid kid) 0)); + let uvar = try Some (KBindings.find (orig_kid kid) inst) with Not_found -> None in + match uvar with + | Some (U_nexp nexp) -> + let sizeof = E_aux (E_sizeof nexp, (l, Some (env, atom_typ nexp, no_effect))) in + (try rewrite_trivial_sizeof_exp sizeof with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err))) + (* If the type variable is Not_found then it was probably + introduced by a P_var pattern, so it likely exists as + a variable in scope. It can't be an existential because the assert rules that out. *) + | None -> annot_exp (E_id (id_of_kid (orig_kid kid))) l env (atom_typ (nvar (orig_kid kid))) + | _ -> + raise (Reporting_basic.err_unreachable l + ("failed to infer nexp for type variable " ^ string_of_kid kid ^ + " of function " ^ string_of_id f)) + end in + let kid_exps = List.map kid_exp (KidSet.elements (Bindings.find f param_map)) in + (E_aux (E_app (f, kid_exps @ args), annot), orig_exp) + else (full_exp, orig_exp) + | _ -> (full_exp, orig_exp) in + + (* Plug this into a folding algorithm that also keeps around a copy of the + original expressions, which we use to infer instantiations of type variables + in the original environments *) + let copy_exp_alg = + { e_block = (fun es -> let (es, es') = List.split es in (E_block es, E_block es')) + ; e_nondet = (fun es -> let (es, es') = List.split es in (E_nondet es, E_nondet es')) + ; e_id = (fun id -> (E_id id, E_id id)) + ; e_lit = (fun lit -> (E_lit lit, E_lit lit)) + ; e_cast = (fun (typ,(e,e')) -> (E_cast (typ,e), E_cast (typ,e'))) + ; e_app = (fun (id,es) -> let (es, es') = List.split es in (E_app (id,es), E_app (id,es'))) + ; e_app_infix = (fun ((e1,e1'),id,(e2,e2')) -> (E_app_infix (e1,id,e2), E_app_infix (e1',id,e2'))) + ; e_tuple = (fun es -> let (es, es') = List.split es in (E_tuple es, E_tuple es')) + ; e_if = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_if (e1,e2,e3), E_if (e1',e2',e3'))) + ; e_for = (fun (id,(e1,e1'),(e2,e2'),(e3,e3'),order,(e4,e4')) -> (E_for (id,e1,e2,e3,order,e4), E_for (id,e1',e2',e3',order,e4'))) + ; e_loop = (fun (lt, (e1, e1'), (e2, e2')) -> (E_loop (lt, e1, e2), E_loop (lt, e1', e2'))) + ; e_vector = (fun es -> let (es, es') = List.split es in (E_vector es, E_vector es')) + ; e_vector_access = (fun ((e1,e1'),(e2,e2')) -> (E_vector_access (e1,e2), E_vector_access (e1',e2'))) + ; e_vector_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_subrange (e1,e2,e3), E_vector_subrange (e1',e2',e3'))) + ; e_vector_update = (fun ((e1,e1'),(e2,e2'),(e3,e3')) -> (E_vector_update (e1,e2,e3), E_vector_update (e1',e2',e3'))) + ; e_vector_update_subrange = (fun ((e1,e1'),(e2,e2'),(e3,e3'),(e4,e4')) -> (E_vector_update_subrange (e1,e2,e3,e4), E_vector_update_subrange (e1',e2',e3',e4'))) + ; e_vector_append = (fun ((e1,e1'),(e2,e2')) -> (E_vector_append (e1,e2), E_vector_append (e1',e2'))) + ; e_list = (fun es -> let (es, es') = List.split es in (E_list es, E_list es')) + ; e_cons = (fun ((e1,e1'),(e2,e2')) -> (E_cons (e1,e2), E_cons (e1',e2'))) + ; e_record = (fun (fexps, fexps') -> (E_record fexps, E_record fexps')) + ; e_record_update = (fun ((e1,e1'),(fexp,fexp')) -> (E_record_update (e1,fexp), E_record_update (e1',fexp'))) + ; e_field = (fun ((e1,e1'),id) -> (E_field (e1,id), E_field (e1',id))) + ; e_case = (fun ((e1,e1'),pexps) -> let (pexps, pexps') = List.split pexps in (E_case (e1,pexps), E_case (e1',pexps'))) + ; e_let = (fun ((lb,lb'),(e2,e2')) -> (E_let (lb,e2), E_let (lb',e2'))) + ; e_assign = (fun ((lexp,lexp'),(e2,e2')) -> (E_assign (lexp,e2), E_assign (lexp',e2'))) + ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) + ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) + ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) + ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) + ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) + ; e_internal_cast = (fun (a,(e1,e1')) -> (E_internal_cast (a,e1), E_internal_cast (a,e1'))) + ; e_internal_exp = (fun a -> (E_internal_exp a, E_internal_exp a)) + ; e_internal_exp_user = (fun (a1,a2) -> (E_internal_exp_user (a1,a2), E_internal_exp_user (a1,a2))) + ; e_comment = (fun c -> (E_comment c, E_comment c)) + ; e_comment_struc = (fun (e,e') -> (E_comment_struc e, E_comment_struc e')) + ; e_internal_let = (fun ((lexp,lexp'), (e2,e2'), (e3,e3')) -> (E_internal_let (lexp,e2,e3), E_internal_let (lexp',e2',e3'))) + ; e_internal_plet = (fun (pat, (e1,e1'), (e2,e2')) -> (E_internal_plet (pat,e1,e2), E_internal_plet (pat,e1',e2'))) + ; e_internal_return = (fun (e,e') -> (E_internal_return e, E_internal_return e')) + ; e_aux = (fun ((e,e'),annot) -> (E_aux (e,annot), E_aux (e',annot))) + ; lEXP_id = (fun id -> (LEXP_id id, LEXP_id id)) + ; lEXP_memory = (fun (id,es) -> let (es, es') = List.split es in (LEXP_memory (id,es), LEXP_memory (id,es'))) + ; lEXP_cast = (fun (typ,id) -> (LEXP_cast (typ,id), LEXP_cast (typ,id))) + ; lEXP_tup = (fun tups -> let (tups,tups') = List.split tups in (LEXP_tup tups, LEXP_tup tups')) + ; lEXP_vector = (fun ((lexp,lexp'),(e2,e2')) -> (LEXP_vector (lexp,e2), LEXP_vector (lexp',e2'))) + ; lEXP_vector_range = (fun ((lexp,lexp'),(e2,e2'),(e3,e3')) -> (LEXP_vector_range (lexp,e2,e3), LEXP_vector_range (lexp',e2',e3'))) + ; lEXP_field = (fun ((lexp,lexp'),id) -> (LEXP_field (lexp,id), LEXP_field (lexp',id))) + ; lEXP_aux = (fun ((lexp,lexp'),annot) -> (LEXP_aux (lexp,annot), LEXP_aux (lexp',annot))) + ; fE_Fexp = (fun (id,(e,e')) -> (FE_Fexp (id,e), FE_Fexp (id,e'))) + ; fE_aux = (fun ((fexp,fexp'),annot) -> (FE_aux (fexp,annot), FE_aux (fexp',annot))) + ; fES_Fexps = (fun (fexps,b) -> let (fexps, fexps') = List.split fexps in (FES_Fexps (fexps,b), FES_Fexps (fexps',b))) + ; fES_aux = (fun ((fexp,fexp'),annot) -> (FES_aux (fexp,annot), FES_aux (fexp',annot))) + ; def_val_empty = (Def_val_empty, Def_val_empty) + ; def_val_dec = (fun (e,e') -> (Def_val_dec e, Def_val_dec e')) + ; def_val_aux = (fun ((defval,defval'),aux) -> (Def_val_aux (defval,aux), Def_val_aux (defval',aux))) + ; pat_exp = (fun (pat,(e,e')) -> (Pat_exp (pat,e), Pat_exp (pat,e'))) + ; pat_when = (fun (pat,(e1,e1'),(e2,e2')) -> (Pat_when (pat,e1,e2), Pat_when (pat,e1',e2'))) + ; pat_aux = (fun ((pexp,pexp'),a) -> (Pat_aux (pexp,a), Pat_aux (pexp',a))) + ; lB_val = (fun (pat,(e,e')) -> (LB_val (pat,e), LB_val (pat,e'))) + ; lB_aux = (fun ((lb,lb'),annot) -> (LB_aux (lb,annot), LB_aux (lb',annot))) + ; pat_alg = id_pat_alg + } in + + let rewrite_sizeof_fun params_map + (FD_aux (FD_function (rec_opt,tannot,eff,funcls),((l,_) as annot))) = + let rewrite_funcl_body (FCL_aux (FCL_Funcl (id,pat,exp), annot)) (funcls,nvars) = + let body_env = env_of exp in + let body_typ = typ_of exp in + let nmap = nexps_from_params pat in + (* first rewrite calls to other functions... *) + let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + (* ... then rewrite sizeof expressions in current function body *) + let exp'' = fold_exp { id_exp_alg with e_sizeof = e_sizeof nmap } exp' in + (FCL_aux (FCL_Funcl (id,pat,exp''), annot) :: funcls, + KidSet.union nvars (sizeof_frees exp'')) in + let (funcls, nvars) = List.fold_right rewrite_funcl_body funcls ([], KidSet.empty) in + (* Add a parameter for each remaining free type-level variable in a + sizeof expression *) + let kid_typ kid = atom_typ (nvar kid) in + let kid_annot kid = simple_annot l (kid_typ kid) in + let kid_pat kid = + P_aux (P_typ (kid_typ kid, + P_aux (P_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)), + kid_annot kid)), kid_annot kid) in + let kid_eaux kid = E_id (Id_aux (Id (string_of_id (id_of_kid kid) ^ "__tv"), l)) in + let kid_typs = List.map kid_typ (KidSet.elements nvars) in + let kid_pats = List.map kid_pat (KidSet.elements nvars) in + let kid_nmap = List.map (fun kid -> (nvar kid, kid_eaux kid)) (KidSet.elements nvars) in + let rewrite_funcl_params (FCL_aux (FCL_Funcl (id, pat, exp), annot) as funcl) = + let rec rewrite_pat (P_aux (pat, ((l, _) as pannot)) as paux) = + let penv = env_of_annot pannot in + let peff = effect_of_annot (snd pannot) in + if KidSet.is_empty nvars then paux else + match pat_typ_of paux with + | Typ_aux (Typ_tup typs, _) -> + let ptyp' = Typ_aux (Typ_tup (kid_typs @ typs), l) in + (match pat with + | P_tup pats -> + P_aux (P_tup (kid_pats @ pats), (l, Some (penv, ptyp', peff))) + | P_wild -> P_aux (pat, (l, Some (penv, ptyp', peff))) + | P_typ (Typ_aux (Typ_tup typs, l), pat) -> + P_aux (P_typ (Typ_aux (Typ_tup (kid_typs @ typs), l), + rewrite_pat pat), (l, Some (penv, ptyp', peff))) + | P_as (_, id) | P_id id -> + (* adding parameters here would change the type of id; + we should remove the P_as/P_id here and add a let-binding to the body *) + raise (Reporting_basic.err_todo l + "rewriting as- or id-patterns for sizeof expressions not yet implemented") + | _ -> + raise (Reporting_basic.err_unreachable l + "unexpected pattern while rewriting function parameters for sizeof expressions")) + | ptyp -> + let ptyp' = Typ_aux (Typ_tup (kid_typs @ [ptyp]), l) in + P_aux (P_tup (kid_pats @ [paux]), (l, Some (penv, ptyp', peff))) in + let exp' = fold_exp { id_exp_alg with e_sizeof = e_sizeof kid_nmap } exp in + FCL_aux (FCL_Funcl (id, rewrite_pat pat, exp'), annot) in + let funcls = List.map rewrite_funcl_params funcls in + (nvars, FD_aux (FD_function (rec_opt,tannot,eff,funcls),annot)) in + + let rewrite_sizeof_def (params_map, defs) = function + | DEF_fundef fd as def -> + let (nvars, fd') = rewrite_sizeof_fun params_map fd in + let id = id_of_fundef fd in + let params_map' = + if KidSet.is_empty nvars then params_map + else Bindings.add id nvars params_map in + (params_map', defs @ [DEF_fundef fd']) + | DEF_val (LB_aux (lb, annot)) -> + begin + let lb' = match lb with + | LB_val (pat, exp) -> + let exp' = fst (fold_exp { copy_exp_alg with e_aux = e_app_aux params_map } exp) in + LB_val (pat, exp') in + (params_map, defs @ [DEF_val (LB_aux (lb', annot))]) + end + | def -> + (params_map, defs @ [def]) in + + let rewrite_sizeof_valspec params_map def = + let rewrite_typschm (TypSchm_aux (TypSchm_ts (tq, typ), l) as ts) id = + if Bindings.mem id params_map then + let kid_typs = List.map (fun kid -> atom_typ (nvar kid)) + (KidSet.elements (Bindings.find id params_map)) in + let typ' = match typ with + | Typ_aux (Typ_fn (vtyp_arg, vtyp_ret, declared_eff), vl) -> + let vtyp_arg' = begin + match vtyp_arg with + | Typ_aux (Typ_tup typs, vl) -> + Typ_aux (Typ_tup (kid_typs @ typs), vl) + | _ -> Typ_aux (Typ_tup (kid_typs @ [vtyp_arg]), vl) + end in + Typ_aux (Typ_fn (vtyp_arg', vtyp_ret, declared_eff), vl) + | _ -> + raise (Reporting_basic.err_typ l "val spec with non-function type") in + TypSchm_aux (TypSchm_ts (tq, typ'), l) + else ts in + match def with + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext, is_cast), a)) -> + DEF_spec (VS_aux (VS_val_spec (rewrite_typschm typschm id, id, ext, is_cast), a)) + | def -> def + in + + let (params_map, defs) = List.fold_left rewrite_sizeof_def + (Bindings.empty, []) defs in + let defs = List.map (rewrite_sizeof_valspec params_map) defs in + Defs defs + (* FIXME: Won't re-check due to flow typing and E_constraint re-write before E_sizeof re-write. + Requires the typechecker to be more smart about different representations for valid flow typing constraints. + fst (check initial_env (Defs defs)) + *) + +let remove_vector_concat_pat pat = + + (* ivc: bool that indicates whether the exp is in a vector_concat pattern *) + let remove_typed_patterns = + fold_pat { id_pat_alg with + p_aux = (function + | (P_typ (_,P_aux (p,_)),annot) + | (p,annot) -> + P_aux (p,annot) + ) + } in + + (* let pat = remove_typed_patterns pat in *) + + let fresh_id_v = fresh_id "v__" in + + (* expects that P_typ elements have been removed from AST, + that the length of all vectors involved is known, + that we don't have indexed vectors *) + + (* introduce names for all patterns of form P_vector_concat *) + let name_vector_concat_roots = + { p_lit = (fun lit -> P_lit lit) + ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) (* cannot happen *) + ; p_wild = P_wild + ; p_as = (fun (pat,id) -> P_as (pat true,id)) + ; p_id = (fun id -> P_id id) + ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) + ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) + ; p_record = (fun (fpats,b) -> P_record (fpats, b)) + ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) + ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) + ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) + ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) + ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_aux = + (fun (pat,((l,_) as annot)) contained_in_p_as -> + match pat with + | P_vector_concat pats -> + (if contained_in_p_as + then P_aux (pat,annot) + else P_aux (P_as (P_aux (pat,annot),fresh_id_v l),annot)) + | _ -> P_aux (pat,annot) + ) + ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) + ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) + } in + + let pat = (fold_pat name_vector_concat_roots pat) false in + + (* introduce names for all unnamed child nodes of P_vector_concat *) + let name_vector_concat_elements = + let p_vector_concat pats = + let rec aux ((P_aux (p,((l,_) as a))) as pat) = match p with + | P_vector _ -> P_aux (P_as (pat,fresh_id_v l),a) + | P_id id -> P_aux (P_id id,a) + | P_as (p,id) -> P_aux (P_as (p,id),a) + | P_typ (typ, pat) -> P_aux (P_typ (typ, aux pat),a) + | P_wild -> P_aux (P_wild,a) + | _ -> + raise + (Reporting_basic.err_unreachable + l "name_vector_concat_elements: Non-vector in vector-concat pattern") in + P_vector_concat (List.map aux pats) in + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat name_vector_concat_elements pat in + + + + let rec tag_last = function + | x :: xs -> let is_last = xs = [] in (x,is_last) :: tag_last xs + | _ -> [] in + + (* remove names from vectors in vector_concat patterns and collect them as declarations for the + function body or expression *) + let unname_vector_concat_elements = (* : + ('a, + 'a pat * ((tannot exp -> tannot exp) list), + 'a pat_aux * ((tannot exp -> tannot exp) list), + 'a fpat * ((tannot exp -> tannot exp) list), + 'a fpat_aux * ((tannot exp -> tannot exp) list)) + pat_alg = *) + + (* build a let-expression of the form "let child = root[i..j] in body" *) + let letbind_vec typ_opt (rootid,rannot) (child,cannot) (i,j) = + let (l,_) = cannot in + let env = env_of_annot rannot in + let rootname = string_of_id rootid in + let childname = string_of_id child in + + let root = E_aux (E_id rootid, rannot) in + let index_i = simple_num l i in + let index_j = simple_num l j in + + (* FIXME *) + let subv = fix_eff_exp (E_aux (E_vector_subrange (root, index_i, index_j), cannot)) in + (* let (_, _, ord, _) = vector_typ_args_of (Env.base_typ_of (env_of root) (typ_of root)) in + let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in + let subv = fix_eff_exp (E_aux (E_app (mk_id subrange_id, [root; index_i; index_j]), cannot)) in *) + + let id_pat = + match typ_opt with + | Some typ -> P_aux (P_typ (typ, P_aux (P_id child,cannot)), cannot) + | None -> P_aux (P_id child,cannot) in + let letbind = fix_eff_lb (LB_aux (LB_val (id_pat,subv),cannot)) in + (letbind, + (fun body -> fix_eff_exp (annot_exp (E_let (letbind,body)) l env (typ_of body))), + (rootname,childname)) in + + let p_aux = function + | ((P_as (P_aux (P_vector_concat pats,rannot'),rootid),decls),rannot) -> + let rtyp = Env.base_typ_of (env_of_annot rannot') (typ_of_annot rannot') in + let (start,last_idx) = (match vector_typ_args_of rtyp with + | (Nexp_aux (Nexp_constant start,_), Nexp_aux (Nexp_constant length,_), ord, _) -> + (start, if is_order_inc ord + then sub_big_int (add_big_int start length) unit_big_int + else add_big_int (sub_big_int start length) unit_big_int) + | _ -> + raise (Reporting_basic.err_unreachable (fst rannot') + ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern"))) in + let rec aux typ_opt (pos,pat_acc,decl_acc) (P_aux (p,cannot),is_last) = + let ctyp = Env.base_typ_of (env_of_annot cannot) (typ_of_annot cannot) in + let (_,length,ord,_) = vector_typ_args_of ctyp in + let (pos',index_j) = match length with + | Nexp_aux (Nexp_constant i,_) -> + if is_order_inc ord + then (add_big_int pos i, sub_big_int (add_big_int pos i) unit_big_int) + else (sub_big_int pos i, add_big_int (sub_big_int pos i) unit_big_int) + | Nexp_aux (_,l) -> + if is_last then (pos,last_idx) + else + raise + (Reporting_basic.err_unreachable + l ("unname_vector_concat_elements: vector of unspecified length in vector-concat pattern")) in + (match p with + (* if we see a named vector pattern, remove the name and remember to + declare it later *) + | P_as (P_aux (p,cannot),cname) -> + let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + (pos', pat_acc @ [P_aux (p,cannot)], decl_acc @ [((lb,decl),info)]) + (* if we see a P_id variable, remember to declare it later *) + | P_id cname -> + let (lb,decl,info) = letbind_vec typ_opt (rootid,rannot) (cname,cannot) (pos,index_j) in + (pos', pat_acc @ [P_aux (P_id cname,cannot)], decl_acc @ [((lb,decl),info)]) + | P_typ (typ, pat) -> aux (Some typ) (pos,pat_acc,decl_acc) (pat, is_last) + (* normal vector patterns are fine *) + | _ -> (pos', pat_acc @ [P_aux (p,cannot)],decl_acc)) in + let pats_tagged = tag_last pats in + let (_,pats',decls') = List.fold_left (aux None) (start,[],[]) pats_tagged in + + (* abuse P_vector_concat as a P_vector_const pattern: it has the of + patterns as an argument but they're meant to be consed together *) + (P_aux (P_as (P_aux (P_vector_concat pats',rannot'),rootid),rannot), decls @ decls') + | ((p,decls),annot) -> (P_aux (p,annot),decls) in + + { p_lit = (fun lit -> (P_lit lit,[])) + ; p_wild = (P_wild,[]) + ; p_as = (fun ((pat,decls),id) -> (P_as (pat,id),decls)) + ; p_typ = (fun (typ,(pat,decls)) -> (P_typ (typ,pat),decls)) + ; p_id = (fun id -> (P_id id,[])) + ; p_var = (fun ((pat,decls),kid) -> (P_var (pat,kid),decls)) + ; p_app = (fun (id,ps) -> let (ps,decls) = List.split ps in + (P_app (id,ps),List.flatten decls)) + ; p_record = (fun (ps,b) -> let (ps,decls) = List.split ps in + (P_record (ps,b),List.flatten decls)) + ; p_vector = (fun ps -> let (ps,decls) = List.split ps in + (P_vector ps,List.flatten decls)) + ; p_vector_concat = (fun ps -> let (ps,decls) = List.split ps in + (P_vector_concat ps,List.flatten decls)) + ; p_tup = (fun ps -> let (ps,decls) = List.split ps in + (P_tup ps,List.flatten decls)) + ; p_list = (fun ps -> let (ps,decls) = List.split ps in + (P_list ps,List.flatten decls)) + ; p_cons = (fun ((p,decls),(p',decls')) -> (P_cons (p,p'), decls @ decls')) + ; p_aux = (fun ((pat,decls),annot) -> p_aux ((pat,decls),annot)) + ; fP_aux = (fun ((fpat,decls),annot) -> (FP_aux (fpat,annot),decls)) + ; fP_Fpat = (fun (id,(pat,decls)) -> (FP_Fpat (id,pat),decls)) + } in + + let (pat,decls) = fold_pat unname_vector_concat_elements pat in + + let decls = + let module S = Set.Make(String) in + + let roots_needed = + List.fold_right + (fun (_,(rootid,childid)) roots_needed -> + if S.mem childid roots_needed then + (* let _ = print_endline rootid in *) + S.add rootid roots_needed + else if String.length childid >= 3 && String.sub childid 0 2 = String.sub "v__" 0 2 then + roots_needed + else + S.add rootid roots_needed + ) decls S.empty in + List.filter + (fun (_,(_,childid)) -> + S.mem childid roots_needed || + String.length childid < 3 || + not (String.sub childid 0 2 = String.sub "v__" 0 2)) + decls in + + let (letbinds,decls) = + let (decls,_) = List.split decls in + List.split decls in + + let decls = List.fold_left (fun f g x -> f (g x)) (fun b -> b) decls in + + + (* at this point shouldn't have P_as patterns in P_vector_concat patterns any more, + all P_as and P_id vectors should have their declarations in decls. + Now flatten all vector_concat patterns *) + + let flatten = + let p_vector_concat ps = + let aux p acc = match p with + | (P_aux (P_vector_concat pats,_)) -> pats @ acc + | pat -> pat :: acc in + P_vector_concat (List.fold_right aux ps []) in + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat flatten pat in + + (* at this point pat should be a flat pattern: no vector_concat patterns + with vector_concats patterns as direct child-nodes anymore *) + + let range a b = + let rec aux a b = if gt_big_int a b then [] else a :: aux (add_big_int a unit_big_int) b in + if gt_big_int a b then List.rev (aux b a) else aux a b in + + let remove_vector_concats = + let p_vector_concat ps = + let aux acc (P_aux (p,annot),is_last) = + let env = env_of_annot annot in + let typ = Env.base_typ_of env (typ_of_annot annot) in + let eff = effect_of_annot (snd annot) in + let (l,_) = annot in + let wild _ = P_aux (P_wild,(gen_loc l, Some (env, bit_typ, eff))) in + if is_vector_typ typ then + match p, vector_typ_args_of typ with + | P_vector ps,_ -> acc @ ps + | _, (_,Nexp_aux (Nexp_constant length,_),_,_) -> + acc @ (List.map wild (range zero_big_int (sub_big_int length unit_big_int))) + | _, _ -> + (*if is_last then*) acc @ [wild zero_big_int] + else raise + (Reporting_basic.err_unreachable l + ("remove_vector_concats: Non-vector in vector-concat pattern " ^ + string_of_typ (typ_of_annot annot))) in + + let has_length (P_aux (p,annot)) = + let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in + match vector_typ_args_of typ with + | (_,Nexp_aux (Nexp_constant length,_),_,_) -> true + | _ -> false in + + let ps_tagged = tag_last ps in + let ps' = List.fold_left aux [] ps_tagged in + let last_has_length ps = List.exists (fun (p,b) -> b && has_length p) ps_tagged in + + if last_has_length ps then + P_vector ps' + else + (* If the last vector pattern in the vector_concat pattern has unknown + length we misuse the P_vector_concat constructor's argument to place in + the following way: P_vector_concat [x;y; ... ;z] should be mapped to the + pattern-match x :: y :: .. z, i.e. if x : 'a, then z : vector 'a. *) + P_vector_concat ps' in + + {id_pat_alg with p_vector_concat = p_vector_concat} in + + let pat = fold_pat remove_vector_concats pat in + + (pat,letbinds,decls) + +(* assumes there are no more E_internal expressions *) +let rewrite_exp_remove_vector_concat_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_case (e,ps) -> + let aux = function + | (Pat_aux (Pat_exp (pat,body),annot')) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + Pat_aux (Pat_exp (pat, decls (rewrite_rec body)),annot') + | (Pat_aux (Pat_when (pat,guard,body),annot')) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + Pat_aux (Pat_when (pat, decls (rewrite_rec guard), decls (rewrite_rec body)),annot') in + rewrap (E_case (rewrite_rec e, List.map aux ps)) + | E_let (LB_aux (LB_val (pat,v),annot'),body) -> + let (pat,_,decls) = remove_vector_concat_pat pat in + rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | exp -> rewrite_base full_exp + +let rewrite_fun_remove_vector_concat_pat + rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = + let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),(l,annot))) = + let (pat',_,decls) = remove_vector_concat_pat pat in + let exp' = decls (rewriters.rewrite_exp rewriters exp) in + (FCL_aux (FCL_Funcl (id,pat',exp'),(l,annot))) + in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),(l,fdannot)) + +let rewrite_defs_remove_vector_concat (Defs defs) = + let rewriters = + {rewrite_exp = rewrite_exp_remove_vector_concat_pat; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp; + rewrite_fun = rewrite_fun_remove_vector_concat_pat; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} in + let rewrite_def d = + let d = rewriters.rewrite_def rewriters d in + match d with + | DEF_val (LB_aux (LB_val (pat,exp),a)) -> + let (pat,letbinds,_) = remove_vector_concat_pat pat in + let defvals = List.map (fun lb -> DEF_val lb) letbinds in + [DEF_val (LB_aux (LB_val (pat,exp),a))] @ defvals + | d -> [d] in + Defs (List.flatten (List.map rewrite_def defs)) + +(* A few helper functions for rewriting guarded pattern clauses. + Used both by the rewriting of P_when and separately by the rewriting of + bitvectors in parameter patterns of function clauses *) + +let remove_wildcards pre (P_aux (_,(l,_)) as pat) = + fold_pat + {id_pat_alg with + p_aux = function + | (P_wild,(l,annot)) -> P_aux (P_id (fresh_id pre l),(l,annot)) + | (p,annot) -> P_aux (p,annot) } + pat + +(* Check if one pattern subsumes the other, and if so, calculate a + substitution of variables that are used in the same position. + TODO: Check somewhere that there are no variable clashes (the same variable + name used in different positions of the patterns) + *) +let rec subsumes_pat (P_aux (p1,annot1) as pat1) (P_aux (p2,annot2) as pat2) = + let rewrap p = P_aux (p,annot1) in + let subsumes_list s pats1 pats2 = + if List.length pats1 = List.length pats2 + then + let subs = List.map2 s pats1 pats2 in + List.fold_right + (fun p acc -> match p, acc with + | Some subst, Some substs -> Some (subst @ substs) + | _ -> None) + subs (Some []) + else None in + match p1, p2 with + | P_lit (L_aux (lit1,_)), P_lit (L_aux (lit2,_)) -> + if lit1 = lit2 then Some [] else None + | P_as (pat1,_), _ -> subsumes_pat pat1 pat2 + | _, P_as (pat2,_) -> subsumes_pat pat1 pat2 + | P_typ (_,pat1), _ -> subsumes_pat pat1 pat2 + | _, P_typ (_,pat2) -> subsumes_pat pat1 pat2 + | P_id (Id_aux (id1,_) as aid1), P_id (Id_aux (id2,_) as aid2) -> + if id1 = id2 then Some [] + else if Env.lookup_id aid1 (env_of_annot annot1) = Unbound && + Env.lookup_id aid2 (env_of_annot annot2) = Unbound + then Some [(id2,id1)] else None + | P_id id1, _ -> + if Env.lookup_id id1 (env_of_annot annot1) = Unbound then Some [] else None + | P_wild, _ -> Some [] + | P_app (Id_aux (id1,l1),args1), P_app (Id_aux (id2,_),args2) -> + if id1 = id2 then subsumes_list subsumes_pat args1 args2 else None + | P_record (fps1,b1), P_record (fps2,b2) -> + if b1 = b2 then subsumes_list subsumes_fpat fps1 fps2 else None + | P_vector pats1, P_vector pats2 + | P_vector_concat pats1, P_vector_concat pats2 + | P_tup pats1, P_tup pats2 + | P_list pats1, P_list pats2 -> + subsumes_list subsumes_pat pats1 pats2 + | P_list (pat1 :: pats1), P_cons _ -> + subsumes_pat (rewrap (P_cons (pat1, rewrap (P_list pats1)))) pat2 + | P_cons _, P_list (pat2 :: pats2)-> + subsumes_pat pat1 (rewrap (P_cons (pat2, rewrap (P_list pats2)))) + | P_cons (pat1, pats1), P_cons (pat2, pats2) -> + (match subsumes_pat pat1 pat2, subsumes_pat pats1 pats2 with + | Some substs1, Some substs2 -> Some (substs1 @ substs2) + | _ -> None) + | _ -> None +and subsumes_fpat (FP_aux (FP_Fpat (id1,pat1),_)) (FP_aux (FP_Fpat (id2,pat2),_)) = + if id1 = id2 then subsumes_pat pat1 pat2 else None + +let equiv_pats pat1 pat2 = + match subsumes_pat pat1 pat2, subsumes_pat pat2 pat1 with + | Some _, Some _ -> true + | _, _ -> false + +let subst_id_pat pat (id1,id2) = + let p_id (Id_aux (id,l)) = (if id = id1 then P_id (Id_aux (id2,l)) else P_id (Id_aux (id,l))) in + fold_pat {id_pat_alg with p_id = p_id} pat + +let subst_id_exp exp (id1,id2) = + (* TODO Don't substitute bound occurrences inside let expressions etc *) + let e_id (Id_aux (id,l)) = (if id = id1 then E_id (Id_aux (id2,l)) else E_id (Id_aux (id,l))) in + fold_exp {id_exp_alg with e_id = e_id} exp + +let rec pat_to_exp (P_aux (pat,(l,annot))) = + let rewrap e = E_aux (e,(l,annot)) in + match pat with + | P_lit lit -> rewrap (E_lit lit) + | P_wild -> raise (Reporting_basic.err_unreachable l + "pat_to_exp given wildcard pattern") + | P_as (pat,id) -> rewrap (E_id id) + | P_typ (_,pat) -> pat_to_exp pat + | P_id id -> rewrap (E_id id) + | P_app (id,pats) -> rewrap (E_app (id, List.map pat_to_exp pats)) + | P_record (fpats,b) -> + rewrap (E_record (FES_aux (FES_Fexps (List.map fpat_to_fexp fpats,b),(l,annot)))) + | P_vector pats -> rewrap (E_vector (List.map pat_to_exp pats)) + | P_vector_concat pats -> raise (Reporting_basic.err_unreachable l + "pat_to_exp not implemented for P_vector_concat") + (* We assume that vector concatenation patterns have been transformed + away already *) + | P_tup pats -> rewrap (E_tuple (List.map pat_to_exp pats)) + | P_list pats -> rewrap (E_list (List.map pat_to_exp pats)) + | P_cons (p,ps) -> rewrap (E_cons (pat_to_exp p, pat_to_exp ps)) +and fpat_to_fexp (FP_aux (FP_Fpat (id,pat),(l,annot))) = + FE_aux (FE_Fexp (id, pat_to_exp pat),(l,annot)) + +let case_exp e t cs = + let l = get_loc_exp e in + let env = env_of e in + let annot = (get_loc_exp e, Some (env_of e, t, no_effect)) in + match cs with + | [(P_aux (P_id id, pannot) as pat, body, _)] -> + fix_eff_exp (annot_exp (E_let (LB_aux (LB_val (pat, e), pannot), body)) l env t) + | _ -> + let pexp (pat,body,annot) = Pat_aux (Pat_exp (pat,body),annot) in + let ps = List.map pexp cs in + (* let efr = union_effs (List.map effect_of_pexp ps) in *) + fix_eff_exp (annot_exp (E_case (e,ps)) l env t) + +let rewrite_guarded_clauses l cs = + let rec group clauses = + let add_clause (pat,cls,annot) c = (pat,cls @ [c],annot) in + let rec group_aux current acc = (function + | ((pat,guard,body,annot) as c) :: cs -> + let (current_pat,_,_) = current in + (match subsumes_pat current_pat pat with + | Some substs -> + let pat' = List.fold_left subst_id_pat pat substs in + let guard' = (match guard with + | Some exp -> Some (List.fold_left subst_id_exp exp substs) + | None -> None) in + let body' = List.fold_left subst_id_exp body substs in + let c' = (pat',guard',body',annot) in + group_aux (add_clause current c') acc cs + | None -> + let pat = remove_wildcards "g__" pat in + group_aux (pat,[c],annot) (acc @ [current]) cs) + | [] -> acc @ [current]) in + let groups = match clauses with + | ((pat,guard,body,annot) as c) :: cs -> + group_aux (remove_wildcards "g__" pat, [c], annot) [] cs + | _ -> + raise (Reporting_basic.err_unreachable l + "group given empty list in rewrite_guarded_clauses") in + List.map (fun cs -> if_pexp cs) groups + and if_pexp (pat,cs,annot) = (match cs with + | c :: _ -> + (* fix_eff_pexp (pexp *) + let body = if_exp pat cs in + let pexp = fix_eff_pexp (Pat_aux (Pat_exp (pat,body),annot)) in + let (Pat_aux (_,annot)) = pexp in + (pat, body, annot) + | [] -> + raise (Reporting_basic.err_unreachable l + "if_pexp given empty list in rewrite_guarded_clauses")) + and if_exp current_pat = (function + | (pat,guard,body,annot) :: ((pat',guard',body',annot') as c') :: cs -> + (match guard with + | Some exp -> + let else_exp = + if equiv_pats current_pat pat' + then if_exp current_pat (c' :: cs) + else case_exp (pat_to_exp current_pat) (typ_of body') (group (c' :: cs)) in + fix_eff_exp (annot_exp (E_if (exp,body,else_exp)) (fst annot) (env_of exp) (typ_of body)) + | None -> body) + | [(pat,guard,body,annot)] -> body + | [] -> + raise (Reporting_basic.err_unreachable l + "if_exp given empty list in rewrite_guarded_clauses")) in + group cs + +let bitwise_and_exp exp1 exp2 = + let (E_aux (_,(l,_))) = exp1 in + let andid = Id_aux (Id "and_bool", gen_loc l) in + annot_exp (E_app(andid,[exp1;exp2])) l (env_of exp1) bool_typ + +let rec contains_bitvector_pat (P_aux (pat,annot)) = match pat with +| P_lit _ | P_wild | P_id _ -> false +| P_as (pat,_) | P_typ (_,pat) -> contains_bitvector_pat pat +| P_vector _ | P_vector_concat _ -> + let typ = Env.base_typ_of (env_of_annot annot) (typ_of_annot annot) in + is_bitvector_typ typ +| P_app (_,pats) | P_tup pats | P_list pats -> + List.exists contains_bitvector_pat pats +| P_cons (p,ps) -> contains_bitvector_pat p || contains_bitvector_pat ps +| P_record (fpats,_) -> + List.exists (fun (FP_aux (FP_Fpat (_,pat),_)) -> contains_bitvector_pat pat) fpats + +let contains_bitvector_pexp = function +| Pat_aux (Pat_exp (pat,_),_) | Pat_aux (Pat_when (pat,_,_),_) -> + contains_bitvector_pat pat + +(* Rewrite bitvector patterns to guarded patterns *) + +let remove_bitvector_pat pat = + + let env = try pat_env_of pat with _ -> Env.empty in + + (* first introduce names for bitvector patterns *) + let name_bitvector_roots = + { p_lit = (fun lit -> P_lit lit) + ; p_typ = (fun (typ,p) -> P_typ (typ,p false)) + ; p_wild = P_wild + ; p_as = (fun (pat,id) -> P_as (pat true,id)) + ; p_id = (fun id -> P_id id) + ; p_var = (fun (pat,kid) -> P_var (pat true,kid)) + ; p_app = (fun (id,ps) -> P_app (id, List.map (fun p -> p false) ps)) + ; p_record = (fun (fpats,b) -> P_record (fpats, b)) + ; p_vector = (fun ps -> P_vector (List.map (fun p -> p false) ps)) + ; p_vector_concat = (fun ps -> P_vector_concat (List.map (fun p -> p false) ps)) + ; p_tup = (fun ps -> P_tup (List.map (fun p -> p false) ps)) + ; p_list = (fun ps -> P_list (List.map (fun p -> p false) ps)) + ; p_cons = (fun (p,ps) -> P_cons (p false, ps false)) + ; p_aux = + (fun (pat,annot) contained_in_p_as -> + let env = env_of_annot annot in + let t = Env.base_typ_of env (typ_of_annot annot) in + let (l,_) = annot in + match pat, is_bitvector_typ t, contained_in_p_as with + | P_vector _, true, false -> + P_aux (P_as (P_aux (pat,annot),fresh_id "b__" l), annot) + | _ -> P_aux (pat,annot) + ) + ; fP_aux = (fun (fpat,annot) -> FP_aux (fpat,annot)) + ; fP_Fpat = (fun (id,p) -> FP_Fpat (id,p false)) + } in + let pat = (fold_pat name_bitvector_roots pat) false in + + (* Then collect guard expressions testing whether the literal bits of a + bitvector pattern match those of a given bitvector, and collect let + bindings for the bits bound by P_id or P_as patterns *) + + (* Helper functions for generating guard expressions *) + let access_bit_exp rootid l typ idx = + let root = annot_exp (E_id rootid) l env typ in + (* FIXME *) + annot_exp (E_vector_access (root, simple_num l idx)) l env bit_typ in + (*let env = env_of_annot rannot in + let t = Env.base_typ_of env (typ_of_annot rannot) in + let (_, _, ord, _) = vector_typ_args_of t in + let access_id = if is_order_inc ord then "bitvector_access_inc" else "bitvector_access_dec" in + E_aux (E_app (mk_id access_id, [root; simple_num l idx]), simple_annot l bit_typ) in*) + + let test_bit_exp rootid l typ idx exp = + let rannot = (l, Some (env_of exp, typ, no_effect)) in + let elem = access_bit_exp rootid l typ idx in + Some (annot_exp (E_app (mk_id "eq", [elem; exp])) l env bool_typ) in + + let test_subvec_exp rootid l typ i j lits = + let (start, length, ord, _) = vector_typ_args_of typ in + let length' = nint (List.length lits) in + let start' = + if is_order_inc ord then nint 0 + else nminus length' (nint 1) in + let typ' = vector_typ start' length' ord bit_typ in + let subvec_exp = + match start, length with + | Nexp_aux (Nexp_constant s, _), Nexp_aux (Nexp_constant l, _) + when eq_big_int s i && eq_big_int l (big_int_of_int (List.length lits)) -> + E_id rootid + | _ -> + (*if vec_start t = i && vec_length t = List.length lits + then E_id rootid + else*) + E_vector_subrange ( + annot_exp (E_id rootid) l env typ, + simple_num l i, + simple_num l j) in + (* let subrange_id = if is_order_inc ord then "bitvector_subrange_inc" else "bitvector_subrange_dec" in + E_app (mk_id subrange_id, [E_aux (E_id rootid, simple_annot l typ); simple_num l i; simple_num l j]) in *) + annot_exp (E_app( + Id_aux (Id "eq_vec", gen_loc l), + [annot_exp subvec_exp l env typ'; + annot_exp (E_vector lits) l env typ'])) l env bool_typ in + + let letbind_bit_exp rootid l typ idx id = + let rannot = simple_annot l typ in + let elem = access_bit_exp rootid l typ idx in + let e = annot_pat (P_id id) l env bit_typ in + let letbind = LB_aux (LB_val (e,elem), (l, Some (env, bit_typ, no_effect))) in + let letexp = (fun body -> + let (E_aux (_,(_,bannot))) = body in + annot_exp (E_let (letbind,body)) l env (typ_of body)) in + (letexp, letbind) in + + let compose_guards guards = + let conj g1 g2 = match g1, g2 with + | Some g1, Some g2 -> Some (bitwise_and_exp g1 g2) + | Some g1, None -> Some g1 + | None, Some g2 -> Some g2 + | None, None -> None in + List.fold_right conj guards None in + + let flatten_guards_decls gd = + let (guards,decls,letbinds) = Util.split3 gd in + (compose_guards guards, (List.fold_right (@@) decls), List.flatten letbinds) in + + (* Collect guards and let bindings *) + let guard_bitvector_pat = + let collect_guards_decls ps rootid t = + let (start,_,ord,_) = vector_typ_args_of t in + let rec collect current (guards,dls) idx ps = + let idx' = if is_order_inc ord then add_big_int idx unit_big_int else sub_big_int idx unit_big_int in + (match ps with + | pat :: ps' -> + (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let e = E_aux (E_lit lit, (gen_loc l, annot)) in + let current' = (match current with + | Some (l,i,j,lits) -> Some (l,i,idx,lits @ [e]) + | None -> Some (l,idx,idx,[e])) in + collect current' (guards, dls) idx' ps' + | P_aux (P_as (pat',id), (l,annot)) -> + let dl = letbind_bit_exp rootid l t idx id in + collect current (guards, dls @ [dl]) idx (pat' :: ps') + | _ -> + let dls' = (match pat with + | P_aux (P_id id, (l,annot)) -> + dls @ [letbind_bit_exp rootid l t idx id] + | _ -> dls) in + let guards' = (match current with + | Some (l,i,j,lits) -> + guards @ [Some (test_subvec_exp rootid l t i j lits)] + | None -> guards) in + collect None (guards', dls') idx' ps') + | [] -> + let guards' = (match current with + | Some (l,i,j,lits) -> + guards @ [Some (test_subvec_exp rootid l t i j lits)] + | None -> guards) in + (guards',dls)) in + let (guards,dls) = match start with + | Nexp_aux (Nexp_constant s, _) -> + collect None ([],[]) s ps + | _ -> + let (P_aux (_, (l,_))) = pat in + raise (Reporting_basic.err_unreachable l + "guard_bitvector_pat called on pattern with non-constant start index") in + let (decls,letbinds) = List.split dls in + (compose_guards guards, List.fold_right (@@) decls, letbinds) in + + let collect_guards_decls_indexed ips rootid t = + let rec guard_decl (idx,pat) = (match pat with + | P_aux (P_lit lit, (l,annot)) -> + let exp = E_aux (E_lit lit, (l,annot)) in + (test_bit_exp rootid l t idx exp, (fun b -> b), []) + | P_aux (P_as (pat',id), (l,annot)) -> + let (guard,decls,letbinds) = guard_decl (idx,pat') in + let (letexp,letbind) = letbind_bit_exp rootid l t idx id in + (guard, decls >> letexp, letbind :: letbinds) + | P_aux (P_id id, (l,annot)) -> + let (letexp,letbind) = letbind_bit_exp rootid l t idx id in + (None, letexp, [letbind]) + | _ -> (None, (fun b -> b), [])) in + let (guards,decls,letbinds) = Util.split3 (List.map guard_decl ips) in + (compose_guards guards, List.fold_right (@@) decls, List.flatten letbinds) in + + { p_lit = (fun lit -> (P_lit lit, (None, (fun b -> b), []))) + ; p_wild = (P_wild, (None, (fun b -> b), [])) + ; p_as = (fun ((pat,gdls),id) -> (P_as (pat,id), gdls)) + ; p_typ = (fun (typ,(pat,gdls)) -> (P_typ (typ,pat), gdls)) + ; p_id = (fun id -> (P_id id, (None, (fun b -> b), []))) + ; p_var = (fun ((pat,gdls),kid) -> (P_var (pat,kid), gdls)) + ; p_app = (fun (id,ps) -> let (ps,gdls) = List.split ps in + (P_app (id,ps), flatten_guards_decls gdls)) + ; p_record = (fun (ps,b) -> let (ps,gdls) = List.split ps in + (P_record (ps,b), flatten_guards_decls gdls)) + ; p_vector = (fun ps -> let (ps,gdls) = List.split ps in + (P_vector ps, flatten_guards_decls gdls)) + ; p_vector_concat = (fun ps -> let (ps,gdls) = List.split ps in + (P_vector_concat ps, flatten_guards_decls gdls)) + ; p_tup = (fun ps -> let (ps,gdls) = List.split ps in + (P_tup ps, flatten_guards_decls gdls)) + ; p_list = (fun ps -> let (ps,gdls) = List.split ps in + (P_list ps, flatten_guards_decls gdls)) + ; p_cons = (fun ((p,gdls),(p',gdls')) -> + (P_cons (p,p'), flatten_guards_decls [gdls;gdls'])) + ; p_aux = (fun ((pat,gdls),annot) -> + let env = env_of_annot annot in + let t = Env.base_typ_of env (typ_of_annot annot) in + (match pat, is_bitvector_typ t with + | P_as (P_aux (P_vector ps, _), id), true -> + (P_aux (P_id id, annot), collect_guards_decls ps id t) + | _, _ -> (P_aux (pat,annot), gdls))) + ; fP_aux = (fun ((fpat,gdls),annot) -> (FP_aux (fpat,annot), gdls)) + ; fP_Fpat = (fun (id,(pat,gdls)) -> (FP_Fpat (id,pat), gdls)) + } in + fold_pat guard_bitvector_pat pat + +let rewrite_exp_remove_bitvector_pat rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_case (e,ps) + when List.exists contains_bitvector_pexp ps -> + let rewrite_pexp = function + | Pat_aux (Pat_exp (pat,body),annot') -> + let (pat',(guard',decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (match guard' with + | Some guard' -> Pat_aux (Pat_when (pat', guard', body'), annot') + | None -> Pat_aux (Pat_exp (pat', body'), annot')) + | Pat_aux (Pat_when (pat,guard,body),annot') -> + let (pat',(guard',decls,_)) = remove_bitvector_pat pat in + let body' = decls (rewrite_rec body) in + (match guard' with + | Some guard' -> Pat_aux (Pat_when (pat', bitwise_and_exp guard guard', body'), annot') + | None -> Pat_aux (Pat_when (pat', guard, body'), annot')) in + rewrap (E_case (e, List.map rewrite_pexp ps)) + | E_let (LB_aux (LB_val (pat,v),annot'),body) -> + let (pat,(_,decls,_)) = remove_bitvector_pat pat in + rewrap (E_let (LB_aux (LB_val (pat,rewrite_rec v),annot'), + decls (rewrite_rec body))) + | _ -> rewrite_base full_exp + +let rewrite_fun_remove_bitvector_pat + rewriters (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot))) = + let _ = reset_fresh_name_counter () in + (* TODO Can there be clauses with different id's in one FD_function? *) + let funcls = match funcls with + | (FCL_aux (FCL_Funcl(id,_,_),_) :: _) -> + let clause (FCL_aux (FCL_Funcl(_,pat,exp),annot)) = + let (pat,(guard,decls,_)) = remove_bitvector_pat pat in + let exp = decls (rewriters.rewrite_exp rewriters exp) in + (pat,guard,exp,annot) in + let cs = rewrite_guarded_clauses l (List.map clause funcls) in + List.map (fun (pat,exp,annot) -> FCL_aux (FCL_Funcl(id,pat,exp),annot)) cs + | _ -> funcls (* TODO is the empty list possible here? *) in + FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),(l,fdannot)) + +let rewrite_defs_remove_bitvector_pats (Defs defs) = + let rewriters = + {rewrite_exp = rewrite_exp_remove_bitvector_pat; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp; + rewrite_fun = rewrite_fun_remove_bitvector_pat; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base } in + let rewrite_def d = + let d = rewriters.rewrite_def rewriters d in + match d with + | DEF_val (LB_aux (LB_val (pat,exp),a)) -> + let (pat',(_,_,letbinds)) = remove_bitvector_pat pat in + let defvals = List.map (fun lb -> DEF_val lb) letbinds in + [DEF_val (LB_aux (LB_val (pat',exp),a))] @ defvals + | d -> [d] in + (* FIXME See above in rewrite_sizeof *) + (* fst (check initial_env ( *) + Defs (List.flatten (List.map rewrite_def defs)) + (* )) *) + + +(* Remove pattern guards by rewriting them to if-expressions within the + pattern expression. Shares code with the rewriting of bitvector patterns. *) +let rewrite_exp_guarded_pats rewriters (E_aux (exp,(l,annot)) as full_exp) = + let rewrap e = E_aux (e,(l,annot)) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + let is_guarded_pexp = function + | Pat_aux (Pat_when (_,_,_),_) -> true + | _ -> false in + match exp with + | E_case (e,ps) + when List.exists is_guarded_pexp ps -> + let clause = function + | Pat_aux (Pat_exp (pat, body), annot) -> + (pat, None, rewrite_rec body, annot) + | Pat_aux (Pat_when (pat, guard, body), annot) -> + (pat, Some guard, rewrite_rec body, annot) in + let clauses = rewrite_guarded_clauses l (List.map clause ps) in + if (effectful e) then + let e = rewrite_rec e in + let (E_aux (_,(el,eannot))) = e in + let pat_e' = fresh_id_pat "p__" (el, Some (env_of e, typ_of e, no_effect)) in + let exp_e' = pat_to_exp pat_e' in + let letbind_e = LB_aux (LB_val (pat_e',e), (el,eannot)) in + let exp' = case_exp exp_e' (typ_of full_exp) clauses in + rewrap (E_let (letbind_e, exp')) + else case_exp e (typ_of full_exp) clauses + | _ -> rewrite_base full_exp + +let rewrite_defs_guarded_pats = + rewrite_defs_base { rewriters_base with rewrite_exp = rewrite_exp_guarded_pats } + + +let id_is_local_var id env = match Env.lookup_id id env with + | Local _ -> true + | _ -> false + +let rec lexp_is_local (LEXP_aux (lexp, _)) env = match lexp with + | LEXP_memory _ -> false + | LEXP_id id + | LEXP_cast (_, id) -> id_is_local_var id env + | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local lexp env) lexps + | LEXP_vector (lexp,_) + | LEXP_vector_range (lexp,_,_) + | LEXP_field (lexp,_) -> lexp_is_local lexp env + +let id_is_unbound id env = match Env.lookup_id id env with + | Unbound -> true + | _ -> false + +let rec lexp_is_local_intro (LEXP_aux (lexp, _)) env = match lexp with + | LEXP_memory _ -> false + | LEXP_id id + | LEXP_cast (_, id) -> id_is_unbound id env + | LEXP_tup lexps -> List.for_all (fun lexp -> lexp_is_local_intro lexp env) lexps + | LEXP_vector (lexp,_) + | LEXP_vector_range (lexp,_,_) + | LEXP_field (lexp,_) -> lexp_is_local_intro lexp env + +let lexp_is_effectful (LEXP_aux (_, (_, annot))) = match annot with + | Some (_, _, eff) -> effectful_effs eff + | _ -> false + +let rec rewrite_local_lexp ((LEXP_aux(lexp,((l,_) as annot))) as le) = + match lexp with + | LEXP_id _ | LEXP_cast (_, _) | LEXP_tup _ -> (le, (fun exp -> exp)) + | LEXP_vector (lexp, e) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update (lexp_to_exp lexp, e, exp), annot)))) + | LEXP_vector_range (lexp, e1, e2) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + (lhs, (fun exp -> rhs (E_aux (E_vector_update_subrange (lexp_to_exp lexp, e1, e2, exp), annot)))) + | LEXP_field (lexp, id) -> + let (lhs, rhs) = rewrite_local_lexp lexp in + let (LEXP_aux (_, recannot)) = lexp in + let field_update exp = FES_aux (FES_Fexps ([FE_aux (FE_Fexp (id, exp), annot)], false), annot) in + (lhs, (fun exp -> rhs (E_aux (E_record_update (lexp_to_exp lexp, field_update exp), recannot)))) + | _ -> raise (Reporting_basic.err_unreachable l ("Unsupported lexp: " ^ string_of_lexp le)) + +(*Expects to be called after rewrite_defs; thus the following should not appear: + internal_exp of any form + lit vectors in patterns or expressions + *) +let rewrite_exp_lift_assign_intro rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = + let rewrap e = E_aux (e,annot) in + let rewrap_effects e eff = + E_aux (e, (l,Some (env_of_annot annot, typ_of_annot annot, eff))) in + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_block exps -> + let rec walker exps = match exps with + | [] -> [] + | (E_aux(E_assign(le,e), ((l, Some (env,typ,eff)) as annot)) as exp)::exps + when lexp_is_local_intro le env && not (lexp_is_effectful le) -> + let (le', re') = rewrite_local_lexp le in + let e' = re' (rewrite_base e) in + let exps' = walker exps in + let effects = union_eff_exps exps' in + let block = E_aux (E_block exps', (l, Some (env, unit_typ, effects))) in + [fix_eff_exp (E_aux (E_internal_let(le', e', block), annot))] + (*| ((E_aux(E_if(c,t,e),(l,annot))) as exp)::exps -> + let vars_t = introduced_variables t in + let vars_e = introduced_variables e in + let new_vars = Envmap.intersect vars_t vars_e in + if Envmap.is_empty new_vars + then (rewrite_base exp)::walker exps + else + let new_nmap = match nmap with + | None -> Some(Nexpmap.empty,new_vars) + | Some(nm,s) -> Some(nm, Envmap.union new_vars s) in + let c' = rewrite_base c in + let t' = rewriters.rewrite_exp rewriters new_nmap t in + let e' = rewriters.rewrite_exp rewriters new_nmap e in + let exps' = walker exps in + fst ((Envmap.fold + (fun (res,effects) i (t,e) -> + let bitlit = E_aux (E_lit (L_aux(L_zero, Parse_ast.Generated l)), + (Parse_ast.Generated l, simple_annot bit_t)) in + let rangelit = E_aux (E_lit (L_aux (L_num 0, Parse_ast.Generated l)), + (Parse_ast.Generated l, simple_annot nat_t)) in + let set_exp = + match t.t with + | Tid "bit" | Tabbrev(_,{t=Tid "bit"}) -> bitlit + | Tapp("range", _) | Tapp("atom", _) -> rangelit + | Tapp("vector", [_;_;_;TA_typ ( {t=Tid "bit"} | {t=Tabbrev(_,{t=Tid "bit"})})]) + | Tapp(("reg"|"register"),[TA_typ ({t = Tapp("vector", + [_;_;_;TA_typ ( {t=Tid "bit"} + | {t=Tabbrev(_,{t=Tid "bit"})})])})]) + | Tabbrev(_,{t = Tapp("vector", + [_;_;_;TA_typ ( {t=Tid "bit"} + | {t=Tabbrev(_,{t=Tid "bit"})})])}) -> + E_aux (E_vector_indexed([], Def_val_aux(Def_val_dec bitlit, + (Parse_ast.Generated l,simple_annot bit_t))), + (Parse_ast.Generated l, simple_annot t)) + | _ -> e in + let unioneffs = union_effects effects (get_effsum_exp set_exp) in + ([E_aux (E_internal_let (LEXP_aux (LEXP_id (Id_aux (Id i, Parse_ast.Generated l)), + (Parse_ast.Generated l, (tag_annot t Emp_intro))), + set_exp, + E_aux (E_block res, (Parse_ast.Generated l, (simple_annot_efr unit_t effects)))), + (Parse_ast.Generated l, simple_annot_efr unit_t unioneffs))],unioneffs))) + (E_aux(E_if(c',t',e'),(Parse_ast.Generated l, annot))::exps',eff_union_exps (c'::t'::e'::exps')) new_vars)*) + | e::exps -> (rewrite_rec e)::(walker exps) + in + rewrap (E_block (walker exps)) + | E_assign(le,e) + when lexp_is_local_intro le (env_of full_exp) && not (lexp_is_effectful le) -> + let (le', re') = rewrite_local_lexp le in + let e' = re' (rewrite_base e) in + let block = annot_exp (E_block []) l (env_of full_exp) unit_typ in + fix_eff_exp (E_aux (E_internal_let(le', e', block), annot)) + | _ -> rewrite_base full_exp + +let rewrite_lexp_lift_assign_intro rewriters ((LEXP_aux(lexp,annot)) as le) = + let rewrap le = LEXP_aux(le,annot) in + let rewrite_base = rewrite_lexp rewriters in + match lexp, annot with + | (LEXP_id id | LEXP_cast (_,id)), (l, Some (env, typ, eff)) -> + (match Env.lookup_id id env with + | Unbound | Local _ -> + LEXP_aux (lexp, (l, Some (env, typ, union_effects eff (mk_effect [BE_lset])))) + | _ -> rewrap lexp) + | _ -> rewrite_base le + + +let rewrite_defs_exp_lift_assign defs = rewrite_defs_base + {rewrite_exp = rewrite_exp_lift_assign_intro; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; + rewrite_lexp = rewrite_lexp_lift_assign_intro; + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} defs + +(*let rewrite_exp_separate_ints rewriters ((E_aux (exp,((l,_) as annot))) as full_exp) = + (*let tparms,t,tag,nexps,eff,cum_eff,bounds = match annot with + | Base((tparms,t),tag,nexps,eff,cum_eff,bounds) -> tparms,t,tag,nexps,eff,cum_eff,bounds + | _ -> [],unit_t,Emp_local,[],pure_e,pure_e,nob in*) + let rewrap e = E_aux (e,annot) in + (*let rewrap_effects e effsum = + E_aux (e,(l,Base ((tparms,t),tag,nexps,eff,effsum,bounds))) in*) + let rewrite_rec = rewriters.rewrite_exp rewriters in + let rewrite_base = rewrite_exp rewriters in + match exp with + | E_lit (L_aux (((L_num _) as lit),_)) -> + (match (is_within_machine64 t nexps) with + | Yes -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int yes\n" in rewrite_base full_exp + | Maybe -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int maybe\n" in rewrite_base full_exp + | No -> let _ = Printf.eprintf "Rewriter of num_const, within 64bit int no\n" in E_aux(E_app(Id_aux (Id "integer_of_int",l),[rewrite_base full_exp]), + (l, Base((tparms,t),External(None),nexps,eff,cum_eff,bounds)))) + | E_cast (typ, exp) -> rewrap (E_cast (typ, rewrite_rec exp)) + | E_app (id,exps) -> rewrap (E_app (id,List.map rewrite_rec exps)) + | E_app_infix(el,id,er) -> rewrap (E_app_infix(rewrite_rec el,id,rewrite_rec er)) + | E_for (id, e1, e2, e3, o, body) -> + rewrap (E_for (id, rewrite_rec e1, rewrite_rec e2, rewrite_rec e3, o, rewrite_rec body)) + | E_vector_access (vec,index) -> rewrap (E_vector_access (rewrite_rec vec,rewrite_rec index)) + | E_vector_subrange (vec,i1,i2) -> + rewrap (E_vector_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2)) + | E_vector_update (vec,index,new_v) -> + rewrap (E_vector_update (rewrite_rec vec,rewrite_rec index,rewrite_rec new_v)) + | E_vector_update_subrange (vec,i1,i2,new_v) -> + rewrap (E_vector_update_subrange (rewrite_rec vec,rewrite_rec i1,rewrite_rec i2,rewrite_rec new_v)) + | E_case (exp ,pexps) -> + rewrap (E_case (rewrite_rec exp, + (List.map + (fun (Pat_aux (Pat_exp(p,e),pannot)) -> + Pat_aux (Pat_exp(rewriters.rewrite_pat rewriters nmap p,rewrite_rec e),pannot)) pexps))) + | E_let (letbind,body) -> rewrap (E_let(rewriters.rewrite_let rewriters nmap letbind,rewrite_rec body)) + | E_internal_let (lexp,exp,body) -> + rewrap (E_internal_let (rewriters.rewrite_lexp rewriters nmap lexp, rewrite_rec exp, rewrite_rec body)) + | _ -> rewrite_base full_exp + +let rewrite_defs_separate_numbs defs = rewrite_defs_base + {rewrite_exp = rewrite_exp_separate_ints; + rewrite_pat = rewrite_pat; + rewrite_let = rewrite_let; (*will likely need a new one?*) + rewrite_lexp = rewrite_lexp; (*will likely need a new one?*) + rewrite_fun = rewrite_fun; + rewrite_def = rewrite_def; + rewrite_defs = rewrite_defs_base} defs*) + +let rewrite_defs_early_return = + let is_return (E_aux (exp, _)) = match exp with + | E_return _ -> true + | _ -> false in + + let get_return (E_aux (e, (l, _)) as exp) = match e with + | E_return e -> e + | _ -> exp in + + let e_block es = + match es with + | [E_aux (e, _)] -> e + | _ :: _ when is_return (Util.last es) -> + let (E_aux (_, annot) as e) = get_return (Util.last es) in + E_return (E_aux (E_block (Util.butlast es @ [get_return e]), annot)) + | _ -> E_block es in + + let e_if (e1, e2, e3) = + if is_return e2 && is_return e3 then + let (E_aux (_, annot)) = get_return e2 in + E_return (E_aux (E_if (e1, get_return e2, get_return e3), annot)) + else E_if (e1, e2, e3) in + + let e_case (e, pes) = + let is_return_pexp (Pat_aux (pexp, _)) = match pexp with + | Pat_exp (_, e) | Pat_when (_, _, e) -> is_return e in + let get_return_pexp (Pat_aux (pexp, a)) = match pexp with + | Pat_exp (p, e) -> Pat_aux (Pat_exp (p, get_return e), a) + | Pat_when (p, g, e) -> Pat_aux (Pat_when (p, g, get_return e), a) in + let annot = match List.map get_return_pexp pes with + | Pat_aux (Pat_exp (_, E_aux (_, annot)), _) :: _ -> annot + | Pat_aux (Pat_when (_, _, E_aux (_, annot)), _) :: _ -> annot + | [] -> (Parse_ast.Unknown, None) in + if List.for_all is_return_pexp pes + then E_return (E_aux (E_case (e, List.map get_return_pexp pes), annot)) + else E_case (e, pes) in + + let e_aux (exp, (l, annot)) = + let full_exp = fix_eff_exp (E_aux (exp, (l, annot))) in + match annot with + | Some (env, typ, eff) when is_return full_exp -> + (* Add escape effect annotation, since we use the exception mechanism + of the state monad to implement early return in the Lem backend *) + let annot' = Some (env, typ, union_effects eff (mk_effect [BE_escape])) in + E_aux (exp, (l, annot')) + | _ -> full_exp in + + let rewrite_funcl_early_return _ (FCL_aux (FCL_Funcl (id, pat, exp), a)) = + let exp = + exp + (* Pull early returns out as far as possible *) + |> fold_exp { id_exp_alg with e_block = e_block; e_if = e_if; e_case = e_case } + (* Remove singleton E_return *) + |> get_return + (* Fix effect annotations *) + |> fold_exp { id_exp_alg with e_aux = e_aux } in + let a = match a with + | (l, Some (env, typ, eff)) -> + (l, Some (env, typ, union_effects eff (effect_of exp))) + | _ -> a in + FCL_aux (FCL_Funcl (id, pat, exp), a) in + + let rewrite_fun_early_return rewriters + (FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, funcls), a)) = + FD_aux (FD_function (rec_opt, tannot_opt, effect_opt, + List.map (rewrite_funcl_early_return rewriters) funcls), a) in + + rewrite_defs_base { rewriters_base with rewrite_fun = rewrite_fun_early_return } + +(* Propagate effects of functions, if effect checking and propagation + have not been performed already by the type checker. *) +let rewrite_fix_val_specs (Defs defs) = + let find_vs env val_specs id = + try Bindings.find id val_specs with + | Not_found -> + begin + try Env.get_val_spec id env with + | _ -> + raise (Reporting_basic.err_unreachable (Parse_ast.Unknown) + ("No val spec found for " ^ string_of_id id)) + end + in + + let add_eff_to_vs eff = function + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff'), a)) -> + (tq, Typ_aux (Typ_fn (args_t, ret_t, union_effects eff eff'), a)) + | vs -> vs + in + + let eff_of_vs = function + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> eff + | _ -> no_effect + in + + let e_aux val_specs (exp, (l, annot)) = + match fix_eff_exp (E_aux (exp, (l, annot))) with + | E_aux (E_app_infix (_, f, _) as exp, (l, Some (env, typ, eff))) + | E_aux (E_app (f, _) as exp, (l, Some (env, typ, eff))) -> + let vs = find_vs env val_specs f in + let env = Env.update_val_spec f vs env in + E_aux (exp, (l, Some (env, typ, union_effects eff (eff_of_vs vs)))) + | e_aux -> e_aux + in + + let rewrite_exp val_specs = fold_exp { id_exp_alg with e_aux = e_aux val_specs } in + + let rewrite_funcl (val_specs, funcls) (FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))) = + let exp = propagate_exp_effect (rewrite_exp val_specs exp) in + let vs, eff = match find_vs (env_of_annot (l, annot)) val_specs id with + | (tq, Typ_aux (Typ_fn (args_t, ret_t, eff), a)) -> + let eff' = union_effects eff (effect_of exp) in + let args_t' = rewrite_typ_nexp_ids (env_of exp) (pat_typ_of pat) in + let ret_t' = rewrite_typ_nexp_ids (env_of exp) (typ_of exp) in + (tq, Typ_aux (Typ_fn (args_t', ret_t', eff'), a)), eff' + in + let annot = add_effect_annot annot eff in + (Bindings.add id vs val_specs, + funcls @ [FCL_aux (FCL_Funcl (id, pat, exp), (l, annot))]) + in + + let rewrite_fundef (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) = + let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in + (* Repeat once to cross-propagate effects between clauses *) + let (val_specs, funcls) = List.fold_left rewrite_funcl (val_specs, []) funcls in + let is_funcl_rec (FCL_aux (FCL_Funcl (id, _, exp), _)) = + fst (fold_exp + { (compute_exp_alg false (||) ) with + e_app = (fun (f, es) -> + let (rs, es) = List.split es in + (List.fold_left (||) (string_of_id f = string_of_id id) rs, + E_app (f, es))); + e_app_infix = (fun ((r1,e1), f, (r2,e2)) -> + (r1 || r2 || (string_of_id f = string_of_id id), + E_app_infix (e1, f, e2))) } + exp) + in + let recopt = + if List.exists is_funcl_rec funcls then + Rec_aux (Rec_rec, Parse_ast.Unknown) + else recopt + in + (val_specs, FD_aux (FD_function (recopt, tannotopt, effopt, funcls), a)) in + + let rec rewrite_fundefs (val_specs, fundefs) = + match fundefs with + | fundef :: fundefs -> + let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in + let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in + (val_specs, fundef :: fundefs) + | [] -> (val_specs, []) in + + let rewrite_def (val_specs, defs) = function + | DEF_fundef fundef -> + let (val_specs, fundef) = rewrite_fundef (val_specs, fundef) in + (val_specs, defs @ [DEF_fundef fundef]) + | DEF_internal_mutrec fundefs -> + let (val_specs, fundefs) = rewrite_fundefs (val_specs, fundefs) in + (val_specs, defs @ [DEF_internal_mutrec fundefs]) + | DEF_val (LB_aux (LB_val (pat, exp), a)) -> + (val_specs, defs @ [DEF_val (LB_aux (LB_val (pat, rewrite_exp val_specs exp), a))]) + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) -> + let typschm, val_specs = + if Bindings.mem id val_specs then begin + let (tq, typ) = Bindings.find id val_specs in + TypSchm_aux (TypSchm_ts (tq, typ), Parse_ast.Unknown), val_specs + end else begin + let (TypSchm_aux (TypSchm_ts (tq, typ), _)) = typschm in + typschm, Bindings.add id (tq, typ) val_specs + end + in + (val_specs, defs @ [DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a))]) + | def -> (val_specs, defs @ [def]) + in + + let rewrite_val_specs val_specs = function + | DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) + when Bindings.mem id val_specs -> + let typschm = match typschm with + | TypSchm_aux (TypSchm_ts (tq, typ), l) -> + let (tq, typ) = Bindings.find id val_specs in + TypSchm_aux (TypSchm_ts (tq, typ), l) + in + DEF_spec (VS_aux (VS_val_spec (typschm, id, ext_opt, is_cast), a)) + | def -> def + in + + let (val_specs, defs) = List.fold_left rewrite_def (Bindings.empty, []) defs in + let defs = List.map (rewrite_val_specs val_specs) defs in + + (* if !Type_check.opt_no_effects + then *) + Defs defs + (* else Defs defs *) + +(* Turn constraints into numeric expressions with sizeof *) +let rewrite_constraint = + let rec rewrite_nc (NC_aux (nc_aux, l)) = mk_exp (rewrite_nc_aux nc_aux) + and rewrite_nc_aux = function + | NC_bounded_ge (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id ">=", mk_exp (E_sizeof n2)) + | NC_bounded_le (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "<=", mk_exp (E_sizeof n2)) + | NC_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "==", mk_exp (E_sizeof n2)) + | NC_not_equal (n1, n2) -> E_app_infix (mk_exp (E_sizeof n1), mk_id "!=", mk_exp (E_sizeof n2)) + | NC_and (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "&", rewrite_nc nc2) + | NC_or (nc1, nc2) -> E_app_infix (rewrite_nc nc1, mk_id "|", rewrite_nc nc2) + | NC_false -> E_lit (mk_lit L_false) + | NC_true -> E_lit (mk_lit L_true) + | NC_set (kid, ints) -> + unaux_exp (rewrite_nc (List.fold_left (fun nc int -> nc_or nc (nc_eq (nvar kid) (nconstant int))) nc_true ints)) + in + let rewrite_e_aux (E_aux (e_aux, _) as exp) = + match e_aux with + | E_constraint nc -> + check_exp (env_of exp) (rewrite_nc nc) bool_typ + | _ -> exp + in + + let rewrite_e_constraint = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in + + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_e_constraint) } + +let rewrite_type_union_typs rw_typ (Tu_aux (tu, annot)) = + match tu with + | Tu_id id -> Tu_aux (Tu_id id, annot) + | Tu_ty_id (typ, id) -> Tu_aux (Tu_ty_id (rw_typ typ, id), annot) + +let rewrite_type_def_typs rw_typ rw_typquant rw_typschm (TD_aux (td, annot)) = + match td with + | TD_abbrev (id, nso, typschm) -> TD_aux (TD_abbrev (id, nso, rw_typschm typschm), annot) + | TD_record (id, nso, typq, typ_ids, flag) -> + TD_aux (TD_record (id, nso, rw_typquant typq, List.map (fun (typ, id) -> (rw_typ typ, id)) typ_ids, flag), annot) + | TD_variant (id, nso, typq, tus, flag) -> + TD_aux (TD_variant (id, nso, rw_typquant typq, List.map (rewrite_type_union_typs rw_typ) tus, flag), annot) + | TD_enum (id, nso, ids, flag) -> TD_aux (TD_enum (id, nso, ids, flag), annot) + | TD_register (id, n1, n2, ranges) -> TD_aux (TD_register (id, n1, n2, ranges), annot) + +(* FIXME: other reg_dec types *) +let rewrite_dec_spec_typs rw_typ (DEC_aux (ds, annot)) = + match ds with + | DEC_reg (typ, id) -> DEC_aux (DEC_reg (rw_typ typ, id), annot) + | _ -> assert false + +(* Remove overload definitions and cast val specs from the + specification because the interpreter doesn't know about them.*) +let rewrite_overload_cast (Defs defs) = + let remove_cast_vs (VS_aux (vs_aux, annot)) = + match vs_aux with + | VS_val_spec (typschm, id, ext, _) -> VS_aux (VS_val_spec (typschm, id, ext, false), annot) + in + let simple_def = function + | DEF_spec vs -> DEF_spec (remove_cast_vs vs) + | def -> def + in + let is_overload = function + | DEF_overload _ -> true + | _ -> false + in + let defs = List.map simple_def defs in + Defs (List.filter (fun def -> not (is_overload def)) defs) + + +let rewrite_undefined mwords = + let rewrite_e_aux (E_aux (e_aux, _) as exp) = + match e_aux with + | E_lit (L_aux (L_undef, l)) -> + check_exp (env_of exp) (undefined_of_typ mwords l (fun _ -> ()) (Env.expand_synonyms (env_of exp) (typ_of exp))) (typ_of exp) + | _ -> exp + in + let rewrite_exp_undefined = { id_exp_alg with e_aux = (fun (exp, annot) -> rewrite_e_aux (E_aux (exp, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp_undefined) } + +let rec simple_typ (Typ_aux (typ_aux, l) as typ) = Typ_aux (simple_typ_aux typ_aux, l) +and simple_typ_aux = function + | Typ_id id -> Typ_id id + | Typ_app (id, [_; _; _; Typ_arg_aux (Typ_arg_typ typ, l)]) when Id.compare id (mk_id "vector") = 0 -> + Typ_app (mk_id "list", [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)]) + | Typ_app (id, [_]) when Id.compare id (mk_id "atom") = 0 -> + Typ_id (mk_id "int") + | Typ_app (id, [_; _]) when Id.compare id (mk_id "range") = 0 -> + Typ_id (mk_id "int") + | Typ_app (id, args) -> Typ_app (id, List.concat (List.map simple_typ_arg args)) + | Typ_fn (typ1, typ2, effs) -> Typ_fn (simple_typ typ1, simple_typ typ2, effs) + | Typ_tup typs -> Typ_tup (List.map simple_typ typs) + | Typ_exist (_, _, Typ_aux (typ, l)) -> simple_typ_aux typ + | typ_aux -> typ_aux +and simple_typ_arg (Typ_arg_aux (typ_arg_aux, l)) = + match typ_arg_aux with + | Typ_arg_typ typ -> [Typ_arg_aux (Typ_arg_typ (simple_typ typ), l)] + | _ -> [] + +(* This pass aims to remove all the Num quantifiers from the specification. *) +let rewrite_simple_types (Defs defs) = + let is_simple = function + | QI_aux (QI_id kopt, annot) as qi when is_typ_kopt kopt || is_order_kopt kopt -> true + | _ -> false + in + let simple_typquant (TypQ_aux (tq_aux, annot)) = + match tq_aux with + | TypQ_no_forall -> TypQ_aux (TypQ_no_forall, annot) + | TypQ_tq quants -> TypQ_aux (TypQ_tq (List.filter (fun q -> is_simple q) quants), annot) + in + let simple_typschm (TypSchm_aux (TypSchm_ts (typq, typ), annot)) = + TypSchm_aux (TypSchm_ts (simple_typquant typq, simple_typ typ), annot) + in + let simple_vs (VS_aux (vs_aux, annot)) = + match vs_aux with + | VS_val_spec (typschm, id, ext, is_cast) -> VS_aux (VS_val_spec (simple_typschm typschm, id, ext, is_cast), annot) + in + let rec simple_lit (L_aux (lit_aux, l) as lit) = + match lit_aux with + | L_bin _ | L_hex _ -> + E_list (List.map (fun b -> E_aux (E_lit b, simple_annot l bit_typ)) (vector_string_to_bit_list l lit_aux)) + | _ -> E_lit lit + in + let simple_def = function + | DEF_spec vs -> DEF_spec (simple_vs vs) + | DEF_type td -> DEF_type (rewrite_type_def_typs simple_typ simple_typquant simple_typschm td) + | DEF_reg_dec ds -> DEF_reg_dec (rewrite_dec_spec_typs simple_typ ds) + | def -> def + in + let simple_pat = { + id_pat_alg with + p_typ = (fun (typ, pat) -> P_typ (simple_typ typ, pat)); + p_var = (fun (pat, kid) -> unaux_pat pat); + p_vector = (fun pats -> P_list pats) + } in + let simple_exp = { + id_exp_alg with + e_lit = simple_lit; + e_vector = (fun exps -> E_list exps); + e_cast = (fun (typ, exp) -> E_cast (simple_typ typ, exp)); + (* e_assert = (fun (E_aux (_, annot), str) -> E_assert (E_aux (E_lit (mk_lit L_true), annot), str)); *) + lEXP_cast = (fun (typ, lexp) -> LEXP_cast (simple_typ typ, lexp)); + pat_alg = simple_pat + } in + let simple_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp simple_exp); + rewrite_pat = (fun _ -> fold_pat simple_pat) } + in + let defs = Defs (List.map simple_def defs) in + rewrite_defs_base simple_defs defs + +let rewrite_tuple_vector_assignments defs = + let assign_tuple e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (LEXP_aux (LEXP_tup lexps, lannot), exp) -> + let typ = Env.base_typ_of env (typ_of exp) in + if is_vector_typ typ then + (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) + let (start, _, ord, etyp) = vector_typ_args_of typ in + let len (LEXP_aux (le, lannot)) = + let ltyp = Env.base_typ_of env (typ_of_annot lannot) in + if is_vector_typ ltyp then + let (_, len, _, _) = vector_typ_args_of ltyp in + match nexp_simp len with + | Nexp_aux (Nexp_constant len, _) -> len + | _ -> unit_big_int + else unit_big_int in + let next i step = + if is_order_inc ord + then (sub_big_int (add_big_int i step) unit_big_int, add_big_int i step) + else (add_big_int (sub_big_int i step) unit_big_int, sub_big_int i step) in + let i = match nexp_simp start with + | (Nexp_aux (Nexp_constant i, _)) -> i + | _ -> if is_order_inc ord then zero_big_int else big_int_of_int (List.length lexps - 1) in + let l = gen_loc (fst annot) in + let exp' = + if small exp then strip_exp exp + else mk_exp (E_id (mk_id "split_vec")) in + let lexp_to_exp (i, exps) lexp = + let (j, i') = next i (len lexp) in + let i_exp = mk_exp (E_lit (mk_lit (L_num i))) in + let j_exp = mk_exp (E_lit (mk_lit (L_num j))) in + let sub = mk_exp (E_vector_subrange (exp', i_exp, j_exp)) in + (i', exps @ [sub]) in + let (_, exps) = List.fold_left lexp_to_exp (i, []) lexps in + let tup = mk_exp (E_tuple exps) in + let lexp = LEXP_aux (LEXP_tup (List.map strip_lexp lexps), (l, ())) in + let e_aux = + if small exp then mk_exp (E_assign (lexp, tup)) + else mk_exp ( + E_let ( + mk_letbind (mk_pat (P_id (mk_id "split_vec"))) (strip_exp exp), + mk_exp (E_assign (lexp, tup)))) in + begin + try check_exp env e_aux unit_typ with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) + end + else E_aux (e_aux, annot) + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_tuple_assignments defs = + let assign_tuple e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (LEXP_aux (LEXP_tup lexps, _), exp) -> + (* let _ = Pretty_print_common.print stderr (Pretty_print_sail.doc_exp (E_aux (e_aux, annot))) in *) + let (_, ids) = List.fold_left (fun (n, ids) _ -> (n + 1, ids @ [mk_id ("tup__" ^ string_of_int n)])) (0, []) lexps in + let block_assign i lexp = mk_exp (E_assign (strip_lexp lexp, mk_exp (E_id (mk_id ("tup__" ^ string_of_int i))))) in + let block = mk_exp (E_block (List.mapi block_assign lexps)) in + let letbind = mk_letbind (mk_pat (P_tup (List.map (fun id -> mk_pat (P_id id)) ids))) (strip_exp exp) in + let let_exp = mk_exp (E_let (letbind, block)) in + begin + try check_exp env let_exp unit_typ with + | Type_error (l, err) -> + raise (Reporting_basic.err_typ l (string_of_type_error err)) + end + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_tuple e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_simple_assignments defs = + let assign_e_aux e_aux annot = + let env = env_of_annot annot in + match e_aux with + | E_assign (lexp, exp) -> + let (lexp, rhs) = rewrite_local_lexp lexp in + let assign = mk_exp (E_assign (strip_lexp lexp, strip_exp (rhs exp))) in + check_exp env assign unit_typ + | _ -> E_aux (e_aux, annot) + in + let assign_exp = { + id_exp_alg with + e_aux = (fun (e_aux, annot) -> assign_e_aux e_aux annot) + } in + let assign_defs = { rewriters_base with rewrite_exp = (fun _ -> fold_exp assign_exp) } in + rewrite_defs_base assign_defs defs + +let rewrite_defs_remove_blocks = + let letbind_wild v body = + let l = get_loc_exp v in + let env = env_of v in + let typ = typ_of v in + annot_exp (E_let (annot_letbind (P_wild, v) l env typ, body)) l env (typ_of body) in + (* let pat = annot_pat P_wild l env typ in + let (E_aux (_,(l,tannot))) = v in + let annot_pat = (simple_annot l (typ_of v)) in + let annot_lb = (gen_loc l, tannot) in + let annot_let = (gen_loc l, Some (env_of body, typ_of body, union_eff_exps [v;body])) in + E_aux (E_let (LB_aux (LB_val (P_aux (P_wild,annot_pat),v),annot_lb),body),annot_let) in *) + + let rec f l = function + | [] -> E_aux (E_lit (L_aux (L_unit,gen_loc l)), (simple_annot l unit_typ)) + | [e] -> e (* check with Kathy if that annotation is fine *) + | e :: es -> letbind_wild e (f l es) in + + let e_aux = function + | (E_block es,(l,_)) -> f l es + | (e,annot) -> E_aux (e,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + + rewrite_defs_base + {rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + + +let letbind (v : 'a exp) (body : 'a exp -> 'a exp) : 'a exp = + (* body is a function : E_id variable -> actual body *) + let (E_aux (_,(l,annot))) = v in + match annot with + | Some (env, Typ_aux (Typ_id tid, _), eff) when string_of_id tid = "unit" -> + let body = body (annot_exp (E_lit (mk_lit L_unit)) l env unit_typ) in + let body_typ = try typ_of body with _ -> unit_typ in + let lb = annot_letbind (P_wild, v) l env unit_typ in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env body_typ) + | Some (env, typ, eff) -> + let id = fresh_id "w__" l in + let lb = annot_letbind (P_id id, v) l env typ in + let body = body (annot_exp (E_id id) l env typ) in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) + | None -> + raise (Reporting_basic.err_unreachable l "no type information") + + +let rec mapCont (f : 'b -> ('b -> 'a exp) -> 'a exp) (l : 'b list) (k : 'b list -> 'a exp) : 'a exp = + match l with + | [] -> k [] + | exp :: exps -> f exp (fun exp -> mapCont f exps (fun exps -> k (exp :: exps))) + +let rewrite_defs_letbind_effects = + + let rec value ((E_aux (exp_aux,_)) as exp) = + not (effectful exp || updates_vars exp) + and value_optdefault (Def_val_aux (o,_)) = match o with + | Def_val_empty -> true + | Def_val_dec e -> value e + and value_fexps (FES_aux (FES_Fexps (fexps,_),_)) = + List.fold_left (fun b (FE_aux (FE_Fexp (_,e),_)) -> b && value e) true fexps in + + + let rec n_exp_name (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + n_exp exp (fun exp -> if value exp then k exp else letbind exp k) + + and n_exp_pure (exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + n_exp exp (fun exp -> if value exp then k exp else letbind exp k) + + and n_exp_nameL (exps : 'a exp list) (k : 'a exp list -> 'a exp) : 'a exp = + mapCont n_exp_name exps k + + and n_fexp (fexp : 'a fexp) (k : 'a fexp -> 'a exp) : 'a exp = + let (FE_aux (FE_Fexp (id,exp),annot)) = fexp in + n_exp_name exp (fun exp -> + k (fix_eff_fexp (FE_aux (FE_Fexp (id,exp),annot)))) + + and n_fexpL (fexps : 'a fexp list) (k : 'a fexp list -> 'a exp) : 'a exp = + mapCont n_fexp fexps k + + and n_pexp (newreturn : bool) (pexp : 'a pexp) (k : 'a pexp -> 'a exp) : 'a exp = + match pexp with + | Pat_aux (Pat_exp (pat,exp),annot) -> + k (fix_eff_pexp (Pat_aux (Pat_exp (pat,n_exp_term newreturn exp), annot))) + | Pat_aux (Pat_when (pat,guard,exp),annot) -> + k (fix_eff_pexp (Pat_aux (Pat_when (pat,n_exp_term newreturn guard,n_exp_term newreturn exp), annot))) + + and n_pexpL (newreturn : bool) (pexps : 'a pexp list) (k : 'a pexp list -> 'a exp) : 'a exp = + mapCont (n_pexp newreturn) pexps k + + and n_fexps (fexps : 'a fexps) (k : 'a fexps -> 'a exp) : 'a exp = + let (FES_aux (FES_Fexps (fexps_aux,b),annot)) = fexps in + n_fexpL fexps_aux (fun fexps_aux -> + k (fix_eff_fexps (FES_aux (FES_Fexps (fexps_aux,b),annot)))) + + and n_opt_default (opt_default : 'a opt_default) (k : 'a opt_default -> 'a exp) : 'a exp = + let (Def_val_aux (opt_default,annot)) = opt_default in + match opt_default with + | Def_val_empty -> k (Def_val_aux (Def_val_empty,annot)) + | Def_val_dec exp -> + n_exp_name exp (fun exp -> + k (fix_eff_opt_default (Def_val_aux (Def_val_dec exp,annot)))) + + and n_lb (lb : 'a letbind) (k : 'a letbind -> 'a exp) : 'a exp = + let (LB_aux (lb,annot)) = lb in + match lb with + | LB_val (pat,exp1) -> + n_exp exp1 (fun exp1 -> + k (fix_eff_lb (LB_aux (LB_val (pat,exp1),annot)))) + + and n_lexp (lexp : 'a lexp) (k : 'a lexp -> 'a exp) : 'a exp = + let (LEXP_aux (lexp_aux,annot)) = lexp in + match lexp_aux with + | LEXP_id _ -> k lexp + | LEXP_memory (id,es) -> + n_exp_nameL es (fun es -> + k (fix_eff_lexp (LEXP_aux (LEXP_memory (id,es),annot)))) + | LEXP_tup es -> + n_lexpL es (fun es -> + k (fix_eff_lexp (LEXP_aux (LEXP_tup es,annot)))) + | LEXP_cast (typ,id) -> + k (fix_eff_lexp (LEXP_aux (LEXP_cast (typ,id),annot))) + | LEXP_vector (lexp,e) -> + n_lexp lexp (fun lexp -> + n_exp_name e (fun e -> + k (fix_eff_lexp (LEXP_aux (LEXP_vector (lexp,e),annot))))) + | LEXP_vector_range (lexp,e1,e2) -> + n_lexp lexp (fun lexp -> + n_exp_name e1 (fun e1 -> + n_exp_name e2 (fun e2 -> + k (fix_eff_lexp (LEXP_aux (LEXP_vector_range (lexp,e1,e2),annot)))))) + | LEXP_field (lexp,id) -> + n_lexp lexp (fun lexp -> + k (fix_eff_lexp (LEXP_aux (LEXP_field (lexp,id),annot)))) + + and n_lexpL (lexps : 'a lexp list) (k : 'a lexp list -> 'a exp) : 'a exp = + mapCont n_lexp lexps k + + and n_exp_term (newreturn : bool) (exp : 'a exp) : 'a exp = + let (E_aux (_,(l,tannot))) = exp in + let exp = + if newreturn then + (* let typ = try typ_of exp with _ -> unit_typ in *) + annot_exp (E_internal_return exp) l (env_of exp) (typ_of exp) + else + exp in + (* n_exp_term forces an expression to be translated into a form + "let .. let .. let .. in EXP" where EXP has no effect and does not update + variables *) + n_exp_pure exp (fun exp -> exp) + + and n_exp (E_aux (exp_aux,annot) as exp : 'a exp) (k : 'a exp -> 'a exp) : 'a exp = + + let rewrap e = fix_eff_exp (E_aux (e,annot)) in + + match exp_aux with + | E_block es -> failwith "E_block should have been removed till now" + | E_nondet _ -> failwith "E_nondet not supported" + | E_id id -> k exp + | E_lit _ -> k exp + | E_cast (typ,exp') -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_cast (typ,exp')))) + | E_app (id,exps) -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_app (id,exps)))) + | E_app_infix (exp1,id,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_app_infix (exp1,id,exp2))))) + | E_tuple exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_tuple exps))) + | E_if (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + let (E_aux (_,annot2)) = exp2 in + let (E_aux (_,annot3)) = exp3 in + let newreturn = effectful exp2 || effectful exp3 in + let exp2 = n_exp_term newreturn exp2 in + let exp3 = n_exp_term newreturn exp3 in + k (rewrap (E_if (exp1,exp2,exp3)))) + | E_for (id,start,stop,by,dir,body) -> + n_exp_name start (fun start -> + n_exp_name stop (fun stop -> + n_exp_name by (fun by -> + let body = n_exp_term (effectful body) body in + k (rewrap (E_for (id,start,stop,by,dir,body)))))) + | E_loop (loop, cond, body) -> + let cond = n_exp_term (effectful cond) cond in + let body = n_exp_term (effectful body) body in + k (rewrap (E_loop (loop,cond,body))) + | E_vector exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_vector exps))) + | E_vector_access (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_vector_access (exp1,exp2))))) + | E_vector_subrange (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + k (rewrap (E_vector_subrange (exp1,exp2,exp3)))))) + | E_vector_update (exp1,exp2,exp3) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + k (rewrap (E_vector_update (exp1,exp2,exp3)))))) + | E_vector_update_subrange (exp1,exp2,exp3,exp4) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + n_exp_name exp3 (fun exp3 -> + n_exp_name exp4 (fun exp4 -> + k (rewrap (E_vector_update_subrange (exp1,exp2,exp3,exp4))))))) + | E_vector_append (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_vector_append (exp1,exp2))))) + | E_list exps -> + n_exp_nameL exps (fun exps -> + k (rewrap (E_list exps))) + | E_cons (exp1,exp2) -> + n_exp_name exp1 (fun exp1 -> + n_exp_name exp2 (fun exp2 -> + k (rewrap (E_cons (exp1,exp2))))) + | E_record fexps -> + n_fexps fexps (fun fexps -> + k (rewrap (E_record fexps))) + | E_record_update (exp1,fexps) -> + n_exp_name exp1 (fun exp1 -> + n_fexps fexps (fun fexps -> + k (rewrap (E_record_update (exp1,fexps))))) + | E_field (exp1,id) -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_field (exp1,id)))) + | E_case (exp1,pexps) -> + let newreturn = List.exists effectful_pexp pexps in + n_exp_name exp1 (fun exp1 -> + n_pexpL newreturn pexps (fun pexps -> + k (rewrap (E_case (exp1,pexps))))) + | E_let (lb,body) -> + n_lb lb (fun lb -> + rewrap (E_let (lb,n_exp body k))) + | E_sizeof nexp -> + k (rewrap (E_sizeof nexp)) + | E_constraint nc -> + k (rewrap (E_constraint nc)) + | E_sizeof_internal annot -> + k (rewrap (E_sizeof_internal annot)) + | E_assign (lexp,exp1) -> + n_lexp lexp (fun lexp -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_assign (lexp,exp1))))) + | E_exit exp' -> k (E_aux (E_exit (n_exp_term (effectful exp') exp'),annot)) + | E_assert (exp1,exp2) -> + n_exp exp1 (fun exp1 -> + n_exp exp2 (fun exp2 -> + k (rewrap (E_assert (exp1,exp2))))) + | E_internal_cast (annot',exp') -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_internal_cast (annot',exp')))) + | E_internal_exp _ -> k exp + | E_internal_exp_user _ -> k exp + | E_internal_let (lexp,exp1,exp2) -> + n_lexp lexp (fun lexp -> + n_exp exp1 (fun exp1 -> + rewrap (E_internal_let (lexp,exp1,n_exp exp2 k)))) + | E_internal_return exp1 -> + n_exp_name exp1 (fun exp1 -> + k (rewrap (E_internal_return exp1))) + | E_comment str -> + k (rewrap (E_comment str)) + | E_comment_struc exp' -> + n_exp exp' (fun exp' -> + k (rewrap (E_comment_struc exp'))) + | E_return exp' -> + n_exp_name exp' (fun exp' -> + k (rewrap (E_return exp'))) + | E_internal_plet _ -> failwith "E_internal_plet should not be here yet" in + + let rewrite_fun _ (FD_aux (FD_function(recopt,tannotopt,effectopt,funcls),fdannot)) = + let effectful_funcl (FCL_aux (FCL_Funcl(_, _, exp), _)) = effectful exp in + let newreturn = List.exists effectful_funcl funcls in + let rewrite_funcl (FCL_aux (FCL_Funcl(id,pat,exp),annot)) = + let _ = reset_fresh_name_counter () in + FCL_aux (FCL_Funcl (id,pat,n_exp_term newreturn exp),annot) + in FD_aux (FD_function(recopt,tannotopt,effectopt,List.map rewrite_funcl funcls),fdannot) in + let rewrite_def rewriters def = + (* let _ = Pretty_print_sail.pp_defs stderr (Defs [def]) in *) + match def with + | DEF_val (LB_aux (lb, annot)) -> + let rewrap lb = DEF_val (LB_aux (lb, annot)) in + begin + match lb with + | LB_val (pat, exp) -> + rewrap (LB_val (pat, n_exp_term (effectful exp) exp)) + end + | DEF_fundef fdef -> DEF_fundef (rewrite_fun rewriters fdef) + | DEF_internal_mutrec fdefs -> + DEF_internal_mutrec (List.map (rewrite_fun rewriters) fdefs) + | d -> d in + rewrite_defs_base + {rewrite_exp = rewrite_exp + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + +let rewrite_defs_effectful_let_expressions = + + let rec pat_of_local_lexp (LEXP_aux (lexp, ((l, _) as annot))) = match lexp with + | LEXP_id id -> P_aux (P_id id, annot) + | LEXP_cast (typ, id) -> P_aux (P_typ (typ, P_aux (P_id id, annot)), annot) + | LEXP_tup lexps -> P_aux (P_tup (List.map pat_of_local_lexp lexps), annot) + | _ -> raise (Reporting_basic.err_unreachable l "unexpected local lexp") in + + let e_let (lb,body) = + match lb with + | LB_aux (LB_val (P_aux (P_wild, _), E_aux (E_assign ((LEXP_aux (_, annot) as le), exp), _)), _) + when lexp_is_local le (env_of_annot annot) && not (lexp_is_effectful le) -> + (* Rewrite assignments to local variables into let bindings *) + let (lhs, rhs) = rewrite_local_lexp le in + E_let (LB_aux (LB_val (pat_of_local_lexp lhs, rhs exp), annot), body) + | LB_aux (LB_val (pat,exp'),annot') -> + if effectful exp' + then E_internal_plet (pat,exp',body) + else E_let (lb,body) in + + let e_internal_let = fun (lexp,exp1,exp2) -> + match lexp with + | LEXP_aux (LEXP_id id,annot) + | LEXP_aux (LEXP_cast (_,id),annot) -> + if effectful exp1 then + E_internal_plet (P_aux (P_id id,annot),exp1,exp2) + else + let lb = LB_aux (LB_val (P_aux (P_id id,annot), exp1), annot) in + E_let (lb, exp2) + | _ -> failwith "E_internal_let with unexpected lexp" in + + let alg = { id_exp_alg with e_let = e_let; e_internal_let = e_internal_let } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +(* Now all expressions have no blocks anymore, any term is a sequence of let-expressions, + * internal let-expressions, or internal plet-expressions ended by a term that does not + * access memory or registers and does not update variables *) + +let dedup eq = + List.fold_left (fun acc e -> if List.exists (eq e) acc then acc else e :: acc) [] + +let eqidtyp (id1,_) (id2,_) = + let name1 = match id1 with Id_aux ((Id name | DeIid name),_) -> name in + let name2 = match id2 with Id_aux ((Id name | DeIid name),_) -> name in + name1 = name2 + +let find_introduced_vars exp = + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_internal_let (LEXP_aux (LEXP_id id, _), _, _), (_, Some (env, _, _)) + | E_internal_let (LEXP_aux (LEXP_cast (_, id), _), _, _), (_, Some (env, _, _)) + when id_is_unbound id env -> IdSet.add id ids + | _ -> ids in + (ids, E_aux (e_aux, annot)) in + fst (fold_exp + { (compute_exp_alg IdSet.empty IdSet.union) with e_aux = e_aux } exp) + +let find_updated_vars exp = + let intros = find_introduced_vars exp in + let e_aux ((ids,e_aux),annot) = + let ids = match e_aux, annot with + | E_assign (LEXP_aux (LEXP_id id, _), _), (_, Some (env, _, _)) + | E_assign (LEXP_aux (LEXP_cast (_, id), _), _), (_, Some (env, _, _)) + when id_is_local_var id env && not (IdSet.mem id intros) -> + (id, annot) :: ids + | _ -> ids in + (ids, E_aux (e_aux, annot)) in + dedup eqidtyp (fst (fold_exp + { (compute_exp_alg [] (@)) with e_aux = e_aux } exp)) + +let swaptyp typ (l,tannot) = match tannot with + | Some (env, typ', eff) -> (l, Some (env, typ, eff)) + | _ -> raise (Reporting_basic.err_unreachable l "swaptyp called with empty type annotation") + +let mktup l es = + match es with + | [] -> annot_exp (E_lit (mk_lit L_unit)) (gen_loc l) Env.empty unit_typ + | [e] -> e + | e :: _ -> + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + propagate_exp_effect (annot_exp (E_tuple es) (gen_loc l) (env_of e) typ) + +let mktup_pat l es = + match es with + | [] -> annot_pat P_wild (gen_loc l) Env.empty unit_typ + | [E_aux (E_id id,_) as exp] -> + annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) + | exp :: _ -> + let typ = mk_typ (Typ_tup (List.map typ_of es)) in + let pats = List.map (function + | (E_aux (E_id id,_) as exp) -> + annot_pat (P_id id) (gen_loc l) (env_of exp) (typ_of exp) + | exp -> + annot_pat P_wild (gen_loc l) (env_of exp) (typ_of exp)) es in + annot_pat (P_tup pats) (gen_loc l) (env_of exp) typ + + +type 'a updated_term = + | Added_vars of 'a exp * 'a pat + | Same_vars of 'a exp + +let rec rewrite_var_updates ((E_aux (expaux,((l,_) as annot))) as exp) = + + let env = env_of exp in + + let rec add_vars overwrite ((E_aux (expaux,annot)) as exp) vars = + match expaux with + | E_let (lb,exp) -> + let exp = add_vars overwrite exp vars in + E_aux (E_let (lb,exp),swaptyp (typ_of exp) annot) + | E_internal_let (lexp,exp1,exp2) -> + let exp2 = add_vars overwrite exp2 vars in + E_aux (E_internal_let (lexp,exp1,exp2), swaptyp (typ_of exp2) annot) + | E_internal_plet (pat,exp1,exp2) -> + let exp2 = add_vars overwrite exp2 vars in + E_aux (E_internal_plet (pat,exp1,exp2), swaptyp (typ_of exp2) annot) + | E_internal_return exp2 -> + let exp2 = add_vars overwrite exp2 vars in + E_aux (E_internal_return exp2,swaptyp (typ_of exp2) annot) + | _ -> + (* after rewrite_defs_letbind_effects there cannot be terms that have + effects/update local variables in "tail-position": check n_exp_term + and where it is used. *) + if overwrite then + match typ_of exp with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> vars + | _ -> raise (Reporting_basic.err_unreachable l + "add_vars: trying to overwrite a non-unit expression in tail-position") + else + let typ' = Typ_aux (Typ_tup [typ_of exp;typ_of vars], gen_loc l) in + E_aux (E_tuple [exp;vars],swaptyp typ' annot) in + + let rewrite (E_aux (expaux,((el,_) as annot))) (P_aux (_,(pl,pannot)) as pat) = + let overwrite = match typ_of_annot annot with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true + | _ -> false in + match expaux with + | E_for(id,exp1,exp2,exp3,order,exp4) -> + (* Translate for loops into calls to one of the foreach combinators. + The loop body becomes a function of the loop variable and any + mutable local variables that are updated inside the loop. + Since the foreach* combinators are higher-order functions, + they cannot be represented faithfully in the AST. The following + code abuses the parameters of an E_app node, embedding the loop body + function as an expression followed by the list of variables it + expects. In (Lem) pretty-printing, this turned into an anonymous + function and passed to foreach*. *) + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars exp4) in + let vartuple = mktup el vars in + let exp4 = rewrite_var_updates (add_vars overwrite exp4 vartuple) in + let (E_aux (_,(_,annot4))) = exp4 in + let fname = match effectful exp4,order with + | false, Ord_aux (Ord_inc,_) -> "foreach_inc" + | false, Ord_aux (Ord_dec,_) -> "foreach_dec" + | true, Ord_aux (Ord_inc,_) -> "foreachM_inc" + | true, Ord_aux (Ord_dec,_) -> "foreachM_dec" + | _ -> raise (Reporting_basic.err_unreachable el + "Could not determine foreach combinator") in + let funcl = Id_aux (Id fname,gen_loc el) in + let loopvar = + (* Don't bother with creating a range type annotation, since the + Lem pretty-printing does not use it. *) + (* let (bf,tf) = match typ_of exp1 with + | {t = Tapp ("atom",[TA_nexp f])} -> (TA_nexp f,TA_nexp f) + | {t = Tapp ("reg", [TA_typ {t = Tapp ("atom",[TA_nexp f])}])} -> (TA_nexp f,TA_nexp f) + | {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])} -> (TA_nexp bf,TA_nexp tf) + | {t = Tapp ("reg", [TA_typ {t = Tapp ("range",[TA_nexp bf;TA_nexp tf])}])} -> (TA_nexp bf,TA_nexp tf) + | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in + let (bt,tt) = match typ_of exp2 with + | {t = Tapp ("atom",[TA_nexp t])} -> (TA_nexp t,TA_nexp t) + | {t = Tapp ("atom",[TA_typ {t = Tapp ("atom", [TA_nexp t])}])} -> (TA_nexp t,TA_nexp t) + | {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])} -> (TA_nexp bt,TA_nexp tt) + | {t = Tapp ("atom",[TA_typ {t = Tapp ("range",[TA_nexp bt;TA_nexp tt])}])} -> (TA_nexp bt,TA_nexp tt) + | {t = Tapp (name,_)} -> failwith (name ^ " shouldn't be here") in + let t = {t = Tapp ("range",match order with + | Ord_aux (Ord_inc,_) -> [bf;tt] + | Ord_aux (Ord_dec,_) -> [tf;bt])} in *) + annot_exp (E_id id) l env int_typ in + let v = E_aux (E_app (funcl,[loopvar;mktup el [exp1;exp2;exp3];exp4;vartuple]), + (gen_loc el, annot4)) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_loop(loop,cond,body) -> + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) (find_updated_vars body) in + let vartuple = mktup el vars in + (* let cond = rewrite_var_updates (add_vars false cond vartuple) in *) + let body = rewrite_var_updates (add_vars overwrite body vartuple) in + let (E_aux (_,(_,bannot))) = body in + let fname = match loop, effectful cond, effectful body with + | While, false, false -> "while_PP" + | While, false, true -> "while_PM" + | While, true, false -> "while_MP" + | While, true, true -> "while_MM" + | Until, false, false -> "until_PP" + | Until, false, true -> "until_PM" + | Until, true, false -> "until_MP" + | Until, true, true -> "until_MM" in + let funcl = Id_aux (Id fname,gen_loc el) in + let v = E_aux (E_app (funcl,[cond;body;vartuple]), (gen_loc el, bannot)) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_if (c,e1,e2) -> + let vars = List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) + (dedup eqidtyp (find_updated_vars e1 @ find_updated_vars e2)) in + if vars = [] then + (Same_vars (E_aux (E_if (c,rewrite_var_updates e1,rewrite_var_updates e2),annot))) + else + let vartuple = mktup el vars in + let e1 = rewrite_var_updates (add_vars overwrite e1 vartuple) in + let e2 = rewrite_var_updates (add_vars overwrite e2 vartuple) in + (* after rewrite_defs_letbind_effects c has no variable updates *) + let env = env_of_annot annot in + let typ = typ_of e1 in + let eff = union_eff_exps [e1;e2] in + let v = E_aux (E_if (c,e1,e2), (gen_loc el, Some (env, typ, eff))) in + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_case (e1,ps) -> + (* after rewrite_defs_letbind_effects e1 needs no rewriting *) + let vars = + let f acc (Pat_aux ((Pat_exp (_,e)|Pat_when (_,_,e)),_)) = + acc @ find_updated_vars e in + List.map (fun (var,(l,t)) -> E_aux (E_id var,(l,t))) + (dedup eqidtyp (List.fold_left f [] ps)) in + if vars = [] then + let ps = List.map (function + | Pat_aux (Pat_exp (p,e),a) -> + Pat_aux (Pat_exp (p,rewrite_var_updates e),a) + | Pat_aux (Pat_when (p,g,e),a) -> + Pat_aux (Pat_when (p,g,rewrite_var_updates e),a)) ps in + Same_vars (E_aux (E_case (e1,ps),annot)) + else + let vartuple = mktup el vars in + let rewrite_pexp (Pat_aux (pexp, (l, _))) = match pexp with + | Pat_exp (pat, exp) -> + let exp = rewrite_var_updates (add_vars overwrite exp vartuple) in + let pannot = (l, Some (env_of exp, typ_of exp, effect_of exp)) in + Pat_aux (Pat_exp (pat, exp), pannot) + | Pat_when _ -> + raise (Reporting_basic.err_unreachable l + "Guarded patterns should have been rewritten already") in + let typ = match ps with + | Pat_aux ((Pat_exp (_,first)|Pat_when (_,_,first)),_) :: _ -> typ_of first + | _ -> unit_typ in + let v = propagate_exp_effect (annot_exp (E_case (e1, List.map rewrite_pexp ps)) pl env typ) in + (* let (ps,typ,effs) = + let f (acc,typ,effs) (Pat_aux (Pat_exp (p,e),pannot)) = + let etyp = typ_of e in + let () = assert (string_of_typ etyp = string_of_typ typ) in + let e = rewrite_var_updates (add_vars overwrite e vartuple) in + let pannot = simple_annot pl (typ_of e) in + let effs = union_effects effs (effect_of e) in + let pat' = Pat_aux (Pat_exp (p,e),pannot) in + (acc @ [pat'],typ,effs) in + List.fold_left f ([],typ,no_effect) ps in + let v = E_aux (E_case (e1,ps), (gen_loc pl, Some (env_of_annot annot, typ, effs))) in *) + let pat = + if overwrite then mktup_pat el vars + else annot_pat (P_tup [pat; mktup_pat pl vars]) pl env (typ_of v) in + Added_vars (v,pat) + | E_assign (lexp,vexp) -> + let effs = match effect_of_annot (snd annot) with + | Effect_aux (Effect_set effs, _) -> effs + | _ -> + raise (Reporting_basic.err_unreachable l + "assignment without effects annotation") in + if effectful exp then + Same_vars (E_aux (E_assign (lexp,vexp),annot)) + else + (match lexp with + | LEXP_aux (LEXP_id id,annot) -> + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_cast (_,id),annot) -> + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_vector (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i),((l1,_) as annot)) -> + let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in + let vexp = annot_exp (E_vector_update (eid,i,vexp)) l1 env (typ_of_annot annot) in + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | LEXP_aux (LEXP_vector_range (LEXP_aux (LEXP_id id,((l2,_) as annot2)),i,j), + ((l,_) as annot)) -> + let eid = annot_exp (E_id id) l2 env (typ_of_annot annot2) in + let vexp = annot_exp (E_vector_update_subrange (eid,i,j,vexp)) l env (typ_of_annot annot) in + let pat = annot_pat (P_id id) pl env (typ_of vexp) in + Added_vars (vexp,pat) + | _ -> Same_vars (E_aux (E_assign (lexp,vexp),annot))) + | _ -> + (* after rewrite_defs_letbind_effects this expression is pure and updates + no variables: check n_exp_term and where it's used. *) + Same_vars (E_aux (expaux,annot)) in + + match expaux with + | E_let (lb,body) -> + let body = rewrite_var_updates body in + let (LB_aux (LB_val (pat, v), lbannot)) = lb in + let lb = match rewrite v pat with + | Added_vars (v, P_aux (pat, _)) -> + annot_letbind (pat, v) (get_loc_exp v) env (typ_of v) + | Same_vars v -> LB_aux (LB_val (pat, v),lbannot) in + propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) + | E_internal_let (lexp,v,body) -> + (* Rewrite E_internal_let into E_let and call recursively *) + let id = match lexp with + | LEXP_aux (LEXP_id id,_) -> id + | LEXP_aux (LEXP_cast (_,id),_) -> id + | _ -> + raise (Reporting_basic.err_unreachable l + "E_internal_let with a lexp that is not a variable") in + let pat = annot_pat (P_id id) l env (typ_of v) in + let lb = annot_letbind (P_id id, v) l env (typ_of v) in + let exp = propagate_exp_effect (annot_exp (E_let (lb, body)) l env (typ_of body)) in + rewrite_var_updates exp + (* let env = env_of_annot annot in + let vtyp = typ_of v in + let veff = effect_of v in + let bodyenv = env_of body in + let bodytyp = typ_of body in + let bodyeff = effect_of body in + let pat = P_aux (P_id id, (simple_annot l vtyp)) in + let lbannot = (gen_loc l, Some (env, vtyp, veff)) in + let lb = LB_aux (LB_val (pat,v),lbannot) in + let exp = E_aux (E_let (lb,body),(gen_loc l, Some (bodyenv, bodytyp, union_effects veff bodyeff))) in + rewrite_var_updates exp *) + | E_internal_plet (pat,v,body) -> + failwith "rewrite_var_updates: E_internal_plet shouldn't be introduced yet" + (* There are no expressions that have effects or variable updates in + "tail-position": check the definition nexp_term and where it is used. *) + | _ -> exp + +let replace_memwrite_e_assign exp = + let e_aux = fun (expaux,annot) -> + match expaux with + | E_assign (LEXP_aux (LEXP_memory (id,args),_),v) -> E_aux (E_app (id,args @ [v]),annot) + | _ -> E_aux (expaux,annot) in + fold_exp { id_exp_alg with e_aux = e_aux } exp + + + +let remove_reference_types exp = + + let rec rewrite_t (Typ_aux (t_aux,a)) = (Typ_aux (rewrite_t_aux t_aux,a)) + and rewrite_t_aux t_aux = match t_aux with + | Typ_app (Id_aux (Id "reg",_), [Typ_arg_aux (Typ_arg_typ (Typ_aux (t_aux2, _)), _)]) -> + rewrite_t_aux t_aux2 + | Typ_app (name,t_args) -> Typ_app (name,List.map rewrite_t_arg t_args) + | Typ_fn (t1,t2,eff) -> Typ_fn (rewrite_t t1,rewrite_t t2,eff) + | Typ_tup ts -> Typ_tup (List.map rewrite_t ts) + | _ -> t_aux + and rewrite_t_arg t_arg = match t_arg with + | Typ_arg_aux (Typ_arg_typ t, a) -> Typ_arg_aux (Typ_arg_typ (rewrite_t t), a) + | _ -> t_arg in + + let rec rewrite_annot = function + | (l, None) -> (l, None) + | (l, Some (env, typ, eff)) -> (l, Some (env, rewrite_t typ, eff)) in + + map_exp_annot rewrite_annot exp + + + +let rewrite_defs_remove_superfluous_letbinds = + + let e_aux (exp,annot) = match exp with + | E_let (lb,exp2) -> + begin match lb,exp2 with + (* 'let x = EXP1 in x' can be replaced with 'EXP1' *) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_id (Id_aux (id',_)),_) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_cast (_,E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' -> + exp1 + (* "let x = EXP1 in return x" can be replaced with 'return (EXP1)', at + least when EXP1 is 'small' enough *) + | LB_aux (LB_val (P_aux (P_id (Id_aux (id,_)),_),exp1),_), + E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' && small exp1 -> + let (E_aux (_,e1annot)) = exp1 in + E_aux (E_internal_return (exp1),e1annot) + | _ -> E_aux (exp,annot) + end + | _ -> E_aux (exp,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +let rewrite_defs_remove_superfluous_returns = + + let has_unittype e = match typ_of e with + | Typ_aux (Typ_id (Id_aux (Id "unit", _)), _) -> true + | _ -> false in + + let e_aux (exp,annot) = match exp with + | E_internal_plet (pat,exp1,exp2) when effectful exp1 -> + begin match pat,exp2 with + | P_aux (P_lit (L_aux (lit,_)),_), + E_aux (E_internal_return (E_aux (E_lit (L_aux (lit',_)),_)),_) + when lit = lit' -> + exp1 + | P_aux (P_wild,pannot), + E_aux (E_internal_return (E_aux (E_lit (L_aux (L_unit,_)),_)),_) + when has_unittype exp1 -> + exp1 + | P_aux (P_id (Id_aux (id,_)),_), + E_aux (E_internal_return (E_aux (E_id (Id_aux (id',_)),_)),_) + when id = id' -> + exp1 + | _ -> E_aux (exp,annot) + end + | _ -> E_aux (exp,annot) in + + let alg = { id_exp_alg with e_aux = e_aux } in + rewrite_defs_base + { rewrite_exp = (fun _ -> fold_exp alg) + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + + +let rewrite_defs_remove_e_assign = + let rewrite_exp _ e = + replace_memwrite_e_assign (remove_reference_types (rewrite_var_updates e)) in + rewrite_defs_base + { rewrite_exp = rewrite_exp + ; rewrite_pat = rewrite_pat + ; rewrite_let = rewrite_let + ; rewrite_lexp = rewrite_lexp + ; rewrite_fun = rewrite_fun + ; rewrite_def = rewrite_def + ; rewrite_defs = rewrite_defs_base + } + +let recheck_defs defs = fst (check initial_env defs) + +let rewrite_defs_lem = [ + ("top_sort_defs", top_sort_defs); + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + (* ("simple_assignments", rewrite_simple_assignments); *) + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); + ("guarded_pats", rewrite_defs_guarded_pats); + (* ("recheck_defs", recheck_defs); *) + ("early_return", rewrite_defs_early_return); + ("nexp_ids", rewrite_defs_nexp_ids); + ("fix_val_specs", rewrite_fix_val_specs); + ("exp_lift_assign", rewrite_defs_exp_lift_assign); + ("remove_blocks", rewrite_defs_remove_blocks); + ("letbind_effects", rewrite_defs_letbind_effects); + ("remove_e_assign", rewrite_defs_remove_e_assign); + ("effectful_let_expressions", rewrite_defs_effectful_let_expressions); + ("remove_superfluous_letbinds", rewrite_defs_remove_superfluous_letbinds); + ("remove_superfluous_returns", rewrite_defs_remove_superfluous_returns) + ] + +let rewrite_defs_ocaml = [ + (* ("top_sort_defs", top_sort_defs); *) + (* ("undefined", rewrite_undefined); *) + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("simple_assignments", rewrite_simple_assignments); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("simple_types", rewrite_simple_types); + ("overload_cast", rewrite_overload_cast); + ("exp_lift_assign", rewrite_defs_exp_lift_assign); + (* ("separate_numbs", rewrite_defs_separate_numbs) *) + ] + +let rewrite_check_annot = + let check_annot exp = + try + prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); + let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in + exp + with + Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) + in + let rewrite_exp = { id_exp_alg with e_aux = (fun (exp, annot) -> check_annot (E_aux (exp, annot))) } in + rewrite_defs_base { rewriters_base with rewrite_exp = (fun _ -> fold_exp rewrite_exp) } + +let rewrite_defs_check = [ + ("check_annotations", rewrite_check_annot); + ] diff --git a/src/rewrites.mli b/src/rewrites.mli new file mode 100644 index 00000000..628296ec --- /dev/null +++ b/src/rewrites.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Thomas Bauereiss *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + +open Ast +open Type_check + +(* Re-write undefined to functions created by -undefined_gen flag *) +val rewrite_undefined : bool -> tannot defs -> tannot defs + +(* Perform rewrites to exclude AST nodes not supported for ocaml out*) +val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list + +(* Perform rewrites to exclude AST nodes not supported for lem out*) +val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list + +(* This is a special rewriter pass that checks AST invariants without + actually doing any re-writing *) +val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list + +val simple_typ : typ -> typ -- cgit v1.2.3 From 9f83f2c0e59eda827c0dce50c087b561f73062d8 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 27 Nov 2017 19:37:56 +0000 Subject: Utility functions in ast_util for asl_parser --- src/ast_util.ml | 3 ++- src/ast_util.mli | 1 + 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index b9e03987..1bce4ce5 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -251,7 +251,8 @@ let npow2 n = Nexp_aux (Nexp_exp n, Parse_ast.Unknown) let nvar kid = Nexp_aux (Nexp_var kid, Parse_ast.Unknown) let nid id = Nexp_aux (Nexp_id id, Parse_ast.Unknown) -let nc_set kid ints = mk_nc (NC_set (kid, ints)) +let nc_set kid nums = mk_nc (NC_set (kid, nums)) +let nc_int_set kid ints = mk_nc (NC_set (kid, List.map big_int_of_int ints)) let nc_eq n1 n2 = mk_nc (NC_equal (n1, n2)) let nc_neq n1 n2 = mk_nc (NC_not_equal (n1, n2)) let nc_lteq n1 n2 = NC_aux (NC_bounded_le (n1, n2), Parse_ast.Unknown) diff --git a/src/ast_util.mli b/src/ast_util.mli index 66d87c71..8206637c 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -133,6 +133,7 @@ val nc_or : n_constraint -> n_constraint -> n_constraint val nc_true : n_constraint val nc_false : n_constraint val nc_set : kid -> big_int list -> n_constraint +val nc_int_set : kid -> int list -> n_constraint (* Negate a n_constraint. Note that there's no NC_not constructor, so this flips all the inequalites a the n_constraint leaves and uses -- cgit v1.2.3 From 32a659a025cb239a32e8a831200e458af3c54c52 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 28 Nov 2017 16:33:34 +0000 Subject: Fix issue where statements in blocks had incorrect environments --- src/rewrites.ml | 3 +++ src/type_check.ml | 5 ++++- src/type_check.mli | 2 ++ 3 files changed, 9 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 74f252f4..363761f5 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2755,6 +2755,9 @@ let rewrite_check_annot = try prerr_endline ("CHECKING: " ^ string_of_exp exp ^ " : " ^ string_of_typ (typ_of exp)); let _ = check_exp (env_of exp) (strip_exp exp) (typ_of exp) in + (if not (alpha_equivalent (env_of exp) (typ_of exp) (Env.expand_synonyms (env_of exp) (typ_of exp))) + then raise (Reporting_basic.err_typ Parse_ast.Unknown "Found synonym in annotation") + else ()); exp with Type_error (l, err) -> raise (Reporting_basic.err_typ l (string_of_type_error err)) diff --git a/src/type_check.ml b/src/type_check.ml index 2260416d..6c158f9e 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -1994,7 +1994,10 @@ let rec check_exp env (E_aux (exp_aux, (l, ())) as exp : unit exp) (Typ_aux (typ match (exp_aux, typ_aux) with | E_block exps, _ -> begin - let rec check_block l env exps typ = match exps with + let rec check_block l env exps typ = + let annot_exp_effect exp typ eff = E_aux (exp, (l, Some (env, typ, eff))) in + let annot_exp exp typ = annot_exp_effect exp typ no_effect in + match exps with | [] -> typ_equality l env typ unit_typ; [] | [exp] -> [crule check_exp env exp typ] | (E_aux (E_assign (lexp, bind), _) :: exps) -> diff --git a/src/type_check.mli b/src/type_check.mli index 99385b31..355740dc 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -231,6 +231,8 @@ val string_of_uvar : uvar -> string val unify : l -> Env.t -> typ -> typ -> uvar KBindings.t * kid list * n_constraint option +val alpha_equivalent : Env.t -> typ -> typ -> bool + (* Throws Invalid_argument if the argument is not a E_app expression *) val instantiation_of : tannot exp -> uvar KBindings.t -- cgit v1.2.3 From 0952ebb7800fe1c396f6916c33bbc19a3b895308 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 28 Nov 2017 18:48:19 +0000 Subject: Small update to trivial sizeof rewrites so we can handle all cases in aarch64 vector instructions. There's maybe a better more general way to do this but I'm not sure what that would be. --- src/rewrites.ml | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/rewrites.ml b/src/rewrites.ml index 363761f5..13d811e4 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -167,6 +167,13 @@ let rewrite_trivial_sizeof, rewrite_trivial_sizeof_exp = let var = E_aux (E_id id, (l, Some (env, typ, no_effect))) in match destruct_atom_nexp env typ with | Some size when prove env (nc_eq size nexp) -> Some var + (* AA: This next case is a bit of a hack... is there a more + general way to deal with trivial nexps that are offset by + constants? This will resolve a 'n - 1 sizeof when 'n is in + scope. *) + | Some size when prove env (nc_eq (nsum size (nint 1)) nexp) -> + let one_exp = infer_exp env (mk_lit_exp (L_num unit_big_int)) in + Some (E_aux (E_app (mk_id "add_range", [var; one_exp]), (gen_loc l, Some (env, atom_typ (nsum size (nint 1)), no_effect)))) | _ -> begin match destruct_vector env typ with -- cgit v1.2.3 From 4469f1295fcdf567edcc71c823fdec6a8194ca94 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 28 Nov 2017 19:56:25 +0000 Subject: Make pretty printer able to print several internal constructs for debugging --- src/pretty_print_sail2.ml | 4 ++++ src/process_file.ml | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index e354fe58..8c8b5661 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -194,6 +194,8 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = separate space [string "match"; doc_exp exp; doc_pexps pexps] | E_let (LB_aux (LB_val (pat, binding), _), exp) -> separate space [string "let"; doc_pat pat; equals; doc_exp binding; string "in"; doc_exp exp] + | E_internal_let (lexp, binding, exp) -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding; string "in"; doc_exp exp] | E_assign (lexp, exp) -> separate space [doc_lexp lexp; equals; doc_exp exp] | E_for (id, exp1, exp2, exp3, order, exp4) -> @@ -247,6 +249,8 @@ and doc_block = function | [] -> string "()" | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> separate space [string "let"; doc_pat pat; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps + | [E_aux (E_internal_let (lexp, binding, E_aux (E_block exps, _)), _)] -> + separate space [string "var"; doc_lexp lexp; equals; doc_exp binding] ^^ semi ^^ hardline ^^ doc_block exps | [exp] -> doc_exp exp | exp :: exps -> doc_exp exp ^^ semi ^^ hardline ^^ doc_block exps and doc_lexp (LEXP_aux (l_aux, _) as lexp) = diff --git a/src/process_file.ml b/src/process_file.ml index e4518837..92b3f328 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -210,7 +210,7 @@ let rewrite_step defs (name,rewriter) = | Some (f, i) -> begin let filename = f ^ "_rewrite_" ^ string_of_int i ^ "_" ^ name ^ ".sail" in - output "" Lem_ast_out [filename, defs]; + (* output "" Lem_ast_out [filename, defs]; *) let ((ot,_, _) as ext_ot) = open_output_with_check_unformatted filename in Pretty_print_sail2.pp_defs ot defs; close_output_with_check ext_ot; -- cgit v1.2.3 From bc29b556b76f4f7f16f4256201bb50fda72da54f Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 14:33:32 +0000 Subject: Added location information for fixity and overloads in ast_util.ml --- src/ast_util.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/ast_util.ml b/src/ast_util.ml index 1bce4ce5..d2712133 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -415,12 +415,12 @@ let def_loc = function | DEF_spec (VS_aux (_, (l, _))) | DEF_default (DT_aux (_, l)) | DEF_scattered (SD_aux (_, (l, _))) - | DEF_reg_dec (DEC_aux (_, (l, _))) -> + | DEF_reg_dec (DEC_aux (_, (l, _))) + | DEF_fixity (_, _, Id_aux (_, l)) + | DEF_overload (Id_aux (_, l), _) -> l | DEF_internal_mutrec _ - | DEF_comm _ - | DEF_overload _ - | DEF_fixity _ -> + | DEF_comm _ -> Parse_ast.Unknown let string_of_id = function -- cgit v1.2.3 From d25a996750978e7624902852bde90a679b50261e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 16:08:57 +0000 Subject: Fix lem_ast output bugs --- src/pretty_print_lem_ast.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index a91a6f08..443a2c63 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -74,7 +74,7 @@ let lemnum default n = "int" ^ string_of_big_int n else if ge_big_int n zero_big_int then default n - else ("(zero - " ^ (default (abs_big_int n)) ^ ")") + else ("(int0 - " ^ (default (abs_big_int n)) ^ ")") let pp_format_id (Id_aux(i,_)) = match i with @@ -300,9 +300,14 @@ let rec pp_format_nes nes = nes) ^*) "]" let pp_format_annot = function + | _ -> "Nothing" + + (* | None -> "Nothing" | Some (_, typ, eff) -> "(Just (" ^ pp_format_typ_lem typ ^ ", " ^ pp_format_effects_lem eff ^ "))" + *) + (* | NoTyp -> "Nothing" | Base((_,t),tag,nes,efct,efctsum,_) -> @@ -471,7 +476,7 @@ and pp_lem_case ppf = function | Pat_aux(Pat_exp(pat,exp),(l,annot)) -> fprintf ppf "@[<1>(Pat_aux (Pat_exp %a@ %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp exp pp_lem_l l pp_annot annot | Pat_aux(Pat_when(pat,guard,exp),(l,annot)) -> - fprintf ppf "@[<1>(Pat_aux (Pat_exp %a@ %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp guard pp_lem_exp exp pp_lem_l l pp_annot annot + fprintf ppf "@[<1>(Pat_aux (Pat_when %a@ %a %a) (%a, %a))@]" pp_lem_pat pat pp_lem_exp guard pp_lem_exp exp pp_lem_l l pp_annot annot and pp_semi_lem_case ppf case = fprintf ppf "@[<1>%a %a@]" pp_lem_case case kwd ";" and pp_lem_lexp ppf (LEXP_aux(lexp,(l,annot))) = -- cgit v1.2.3 From 636d81ee6afba69b7a2516e8149eeef3691cd67e Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 18:13:17 +0000 Subject: Switched to bytecode compiler for executing interpreter to avoid stack overflow --- src/Makefile | 8 ++++++-- src/lem_interp/instruction_extractor.lem | 5 ++++- src/pretty_print_lem_ast.ml | 12 +++++++----- 3 files changed, 17 insertions(+), 8 deletions(-) (limited to 'src') diff --git a/src/Makefile b/src/Makefile index 298d22c8..e0c1e45c 100644 --- a/src/Makefile +++ b/src/Makefile @@ -79,7 +79,8 @@ LEM = $(BITBUCKET_ROOT)/lem/lem LEMLIBOCAML = $(BITBUCKET_ROOT)/lem/ocaml-lib ELFDIR= $(BITBUCKET_ROOT)/linksem ZARITH_DIR=$(LEMLIBOCAML)/dependencies/zarith -ZARITH_LIB=$(ZARITH_DIR)/zarith.cmxa +ZARITH_LIB=$(ZARITH_DIR)/zarith.cma +# ZARITH_LIB=$(ZARITH_DIR)/zarith.cmxa SAIL_LIB_DIR:=$(SAIL_DIR)/lib MIPS_SAIL_DIR:=$(SAIL_DIR)/mips_new_tc @@ -204,8 +205,11 @@ count: _build/cheri_trimmed.sail _build/mips_trimmed.sail %.ml: %.lem $(LEM) -only_changed_output -ocaml -lib lem_interp/ $< +#run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter +# env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native + run_mips.native: _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml interpreter - env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native + env OCAMLRUNPARAM=l=100M ocamlfind ocamlc $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cma $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cma $(ELFDIR)/src/linksem.cma _build/pprint/src/PPrintLib.cma _build/lem_interp/extract.cma _build/mips.ml _build/mips_extras.ml _build/run_with_elf.ml -o run_mips.native run_cheri.native: _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml interpreter env OCAMLRUNPARAM=l=100M ocamlfind ocamlopt $(OCAML_OPTS) -g -package num -package str -package unix -I $(ELFDIR)/contrib/ocaml-uint/_build/lib -I $(LEMLIBOCAML) -I $(ZARITH_DIR) -I _build/lem_interp/ -I $(ELFDIR)/src -I $(ELFDIR)/src/adaptors -I $(ELFDIR)/src/abis/mips64 -I _build -linkpkg $(ZARITH_LIB) $(LEMLIBOCAML)/extract.cmxa $(ELFDIR)/contrib/ocaml-uint/_build/lib/uint.cmxa $(ELFDIR)/src/linksem.cmxa _build/pprint/src/PPrintLib.cmxa _build/lem_interp/extract.cmxa _build/cheri.ml _build/mips_extras.ml _build/run_with_elf_cheri.ml -o run_cheri.native diff --git a/src/lem_interp/instruction_extractor.lem b/src/lem_interp/instruction_extractor.lem index 8bc19f8c..056f0100 100644 --- a/src/lem_interp/instruction_extractor.lem +++ b/src/lem_interp/instruction_extractor.lem @@ -127,7 +127,10 @@ let rec extract_patt_parm (P_aux p (_,tannot)) = let rec extract_from_execute fcls = match fcls with | [] -> [] | FCL_aux (FCL_Funcl _ (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 + (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 = diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 443a2c63..65d99780 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -300,13 +300,15 @@ let rec pp_format_nes nes = nes) ^*) "]" let pp_format_annot = function - | _ -> "Nothing" - - (* | None -> "Nothing" | Some (_, typ, eff) -> - "(Just (" ^ pp_format_typ_lem typ ^ ", " ^ pp_format_effects_lem eff ^ "))" - *) + "(Just (" + ^ pp_format_typ_lem typ ^ ", " + ^ "Tag_empty" ^ ", " + ^ "[], " + ^ pp_format_effects_lem eff ^ ", " + ^ pp_format_effects_lem eff + ^ "))" (* | NoTyp -> "Nothing" -- cgit v1.2.3 From 16c475fff5b1942eacc4f399ff14a0bca0c9cec2 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Wed, 29 Nov 2017 19:29:48 +0000 Subject: Better lem_ast tagging and interpreter tweaks --- src/lem_interp/interp_inter_imp.lem | 3 ++- src/lem_interp/run_interp_model.ml | 8 +++---- src/pretty_print_lem_ast.ml | 46 ++++++++++++------------------------- 3 files changed, 21 insertions(+), 36 deletions(-) (limited to 'src') diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index 68f82ccb..e9533a2a 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -440,7 +440,8 @@ let rec interp_to_value_helper debug arg ivh_mode err_str instr direction regist (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) - | _ -> (Ivh_error (Interp_interface.Internal_error ("Non expected action 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 = diff --git a/src/lem_interp/run_interp_model.ml b/src/lem_interp/run_interp_model.ml index 6978aeb9..81f0a5fd 100644 --- a/src/lem_interp/run_interp_model.ml +++ b/src/lem_interp/run_interp_model.ml @@ -433,7 +433,7 @@ let run (List.combine nondets (List.map (fun _ -> Random.bits ()) nondets)) in show "nondeterministic evaluation begun" "" "" ""; let (_,_,_,env') = List.fold_right (fun (next,_) (_,_,_,env') -> - loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies false) next)) + loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies true) next)) choose_order (false,mode,!track_dependencies,env'); in show "nondeterministic evaluation ended" "" "" ""; (step next,env',next) @@ -445,7 +445,7 @@ let run else begin show "undefined triggered a non_det" "" "" ""; let (_,_,_,env') = List.fold_right (fun (next,_) (_,_,_,env') -> - loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies false) next)) + loop mode env' (interp0 (make_mode (mode=Run) !track_dependencies true) next)) choose_order (false,mode,!track_dependencies,env'); in (step i_state,env',i_state) end | Escape0(Some e,_) -> @@ -462,11 +462,11 @@ let run | Write_memv1 _ -> assert false) (*| _ -> assert false*) in - loop mode' env' (Interp_inter_imp.interp0 (make_mode (mode' = Run) !track_dependencies false) next) in + loop mode' env' (Interp_inter_imp.interp0 (make_mode (mode' = Run) !track_dependencies true) next) in let mode = match mode with | None -> if eager_eval then Run else Step | Some m -> m in - let imode = make_mode eager_eval !track_dependencies false in + let imode = make_mode eager_eval !track_dependencies true in let (IState(instr_state,context)) = istate in let (top_exp,(top_env,top_mem)) = top_frame_exp_state instr_state in interactf "%s: %s %s\n" (grey name) (blue "evaluate") diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 65d99780..65fa5d25 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -281,45 +281,28 @@ let pp_format_lit_lem (L_aux(lit,l)) = let pp_lem_lit ppf l = base ppf (pp_format_lit_lem l) -let rec pp_format_nes nes = - "[" ^ (* - (list_format "; " - (fun ne -> match ne with - | LtEq(_,n1,n2) -> "(Nec_lteq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | Eq(_,n1,n2) -> "(Nec_eq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | GtEq(_,n1,n2) -> "(Nec_gteq " ^ pp_format_n_lem n1 ^ " " ^ pp_format_n_lem n2 ^ ")" - | In(_,i,ns) | InS(_,{nexp=Nvar i},ns) -> - "(Nec_in \"" ^ i ^ "\" [" ^ (list_format "; " string_of_int ns)^ "])" - | InS(_,_,ns) -> - "(Nec_in \"fresh\" [" ^ (list_format "; " string_of_int ns)^ "])" - | CondCons(_,nes_c,nes_t) -> - "(Nec_cond " ^ (pp_format_nes nes_c) ^ " " ^ (pp_format_nes nes_t) ^ ")" - | BranchCons(_,nes_b) -> - "(Nec_branch " ^ (pp_format_nes nes_b) ^ ")" - ) - nes) ^*) "]" - -let pp_format_annot = function +let tag_id id env = + if Env.is_extern id env "lem_ast" then + "Tag_extern (Just \"" ^ Ast_util.string_of_id id ^ "\")" + else if Env.is_union_constructor id env then + "Tag_ctor" + else + "Tag_empty" + +let pp_format_annot ?tag:(t="Tag_empty") = function | None -> "Nothing" | Some (_, typ, eff) -> "(Just (" ^ pp_format_typ_lem typ ^ ", " - ^ "Tag_empty" ^ ", " + ^ t ^ ", " ^ "[], " ^ pp_format_effects_lem eff ^ ", " ^ pp_format_effects_lem eff ^ "))" -(* - | NoTyp -> "Nothing" - | Base((_,t),tag,nes,efct,efctsum,_) -> - (*TODO print out bindings for use in pattern match in interpreter*) - "(Just (" ^ pp_format_t_lem t ^ ", " ^ pp_format_tag tag ^ ", " ^ pp_format_nes nes ^ ", " ^ - pp_format_e_lem efct ^ ", " ^ pp_format_e_lem efctsum ^ "))" - | Overload _ -> "Nothing" *) - let pp_annot ppf ant = base ppf (pp_format_annot ant) +let pp_annot_tag tag ppf ant = base ppf (pp_format_annot ~tag:tag ant) let rec pp_format_pat_lem (P_aux(p,(l,annot))) = "(P_aux " ^ @@ -352,7 +335,8 @@ let rec pp_lem_let ppf (LB_aux(lb,(l,annot))) = fprintf ppf "@[<0>(%a %a %a)@]" kwd "LB_val" pp_lem_pat pat pp_lem_exp exp in fprintf ppf "@[<0>(LB_aux %a (%a, %a))@]" print_lb lb pp_lem_l l pp_annot annot -and pp_lem_exp ppf (E_aux(e,(l,annot))) = +and pp_lem_exp ppf (E_aux(e,(l,annot)) as exp) = + let env = env_of exp in let print_e ppf e = match e with | E_block(exps) -> fprintf ppf "@[<0>(E_aux %a [%a] %a (%a, %a))@]" @@ -363,13 +347,13 @@ and pp_lem_exp ppf (E_aux(e,(l,annot))) = kwd "(E_nondet" (list_pp pp_semi_lem_exp pp_lem_exp) exps kwd ")" pp_lem_l l pp_annot annot - | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l pp_annot annot + | E_id(id) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_id" pp_lem_id id pp_lem_l l (pp_annot_tag (tag_id id env)) annot | E_lit(lit) -> fprintf ppf "(E_aux (%a %a) (%a, %a))" kwd "E_lit" pp_lem_lit lit pp_lem_l l pp_annot annot | E_cast(typ,exp) -> fprintf ppf "@[<0>(E_aux (E_cast %a %a) (%a, %a))@]" pp_lem_typ typ pp_lem_exp exp pp_lem_l l pp_annot annot | E_internal_cast((_,None),e) -> pp_lem_exp ppf e | E_app(f,args) -> fprintf ppf "@[<0>(E_aux (E_app %a [%a]) (%a, %a))@]" - pp_lem_id f (list_pp pp_semi_lem_exp pp_lem_exp) args pp_lem_l l pp_annot annot + pp_lem_id f (list_pp pp_semi_lem_exp pp_lem_exp) args pp_lem_l l (pp_annot_tag (tag_id f env)) annot | E_app_infix(l',op,r) -> fprintf ppf "@[<0>(E_aux (E_app_infix %a %a %a) (%a, %a))@]" pp_lem_exp l' pp_lem_id op pp_lem_exp r pp_lem_l l pp_annot annot | E_tuple(exps) -> fprintf ppf "@[<0>(E_aux (E_tuple [%a]) (%a, %a))@]" -- cgit v1.2.3 From dd00feacb373defbcfd8c50b9a8381c4a7db7cba Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 30 Nov 2017 19:35:35 +0000 Subject: Improvements to enable parsing and checking intermediate rewriting steps Parser now has syntax for mutual recusion blocks mutual { ... fundefs ... } which is used for parsing and pretty printing DEF_internal_mutrec. It's stripped away by the initial_check, so the typechecker never sees DEF_internal_mutrec. Maybe this could change, as forcing mutual recursion to be explicit would probably be a good thing. Added record syntax to the new parser New option -dmagic_hash is similar to GHC's -XMagicHash in that it allows for identifiers to contain the special hash character, which is used to introduce new autogenerated variables in a way that doesn't clash with existing names. Option -sil compiles sail down to the intermediate language defined in sil.ott (not complete yet). --- src/initial_check.ml | 33 ++++++++++++++++++++++++++++----- src/initial_check.mli | 1 + src/lexer2.mll | 6 +++++- src/parse_ast.ml | 3 ++- src/parser2.mly | 28 ++++++++++++++++++++++++++-- src/pretty_print_sail2.ml | 24 +++++++++++------------- src/process_file.ml | 1 + src/process_file.mli | 1 + src/rewrites.ml | 12 ++++++++++++ src/rewrites.mli | 3 +++ src/sail.ml | 12 ++++++++++++ 11 files changed, 102 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/initial_check.ml b/src/initial_check.ml index de5b625b..2764c30b 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -46,6 +46,7 @@ open Ast_util open Big_int let opt_undefined_gen = ref false +let opt_magic_hash = ref false module Envmap = Finite_map.Fmap_map(String) module Nameset' = Set.Make(String) @@ -117,10 +118,21 @@ let typ_error l msg opt_id opt_var opt_kind = | None,None,Some(kind) -> " " ^ (kind_to_string kind) | _ -> ""))) -let to_ast_id (Parse_ast.Id_aux(id,l)) = - Id_aux( (match id with - | Parse_ast.Id(x) -> Id(x) - | Parse_ast.DeIid(x) -> DeIid(x)) , l) +let string_of_parse_id_aux = function + | Parse_ast.Id v -> v + | Parse_ast.DeIid v -> v + +let string_contains str char = + try (String.index str char; true) with + | Not_found -> false + +let to_ast_id (Parse_ast.Id_aux(id, l)) = + if string_contains (string_of_parse_id_aux id) '#' && not (!opt_magic_hash) + then typ_error l "Identifier contains hash character" None None None + else Id_aux ((match id with + | Parse_ast.Id(x) -> Id(x) + | Parse_ast.DeIid(x) -> DeIid(x)), + l) let to_ast_var (Parse_ast.Kid_aux(Parse_ast.Var v,l)) = Kid_aux(Var v,l) @@ -483,7 +495,10 @@ and to_ast_exp (k_env : kind Envmap.t) (def_ord : order) (Parse_ast.E_aux(exp,l) | Parse_ast.E_vector_append(e1,e2) -> E_vector_append(to_ast_exp k_env def_ord e1,to_ast_exp k_env def_ord e2) | Parse_ast.E_list(exps) -> E_list(List.map (to_ast_exp k_env def_ord) exps) | Parse_ast.E_cons(e1,e2) -> E_cons(to_ast_exp k_env def_ord e1, to_ast_exp k_env def_ord e2) - | Parse_ast.E_record _ -> raise (Reporting_basic.err_unreachable l "parser generated an E_record") + | Parse_ast.E_record fexps -> + (match to_ast_fexps true k_env def_ord fexps with + | Some fexps -> E_record fexps + | None -> raise (Reporting_basic.err_unreachable l "to_ast_fexps with true returned none")) | Parse_ast.E_record_update(exp,fexps) -> (match to_ast_fexps true k_env def_ord fexps with | Some(fexps) -> E_record_update(to_ast_exp k_env def_ord exp, fexps) @@ -886,7 +901,15 @@ let rec to_ast_defs_helper envs partial_defs = function then (fst !d) :: defs, envs, partial_defs else typ_error l "Scattered type definition never ended" (Some id) None None)) +let rec remove_mutrec = function + | [] -> [] + | Parse_ast.DEF_internal_mutrec fundefs :: defs -> + List.map (fun fdef -> Parse_ast.DEF_fundef fdef) fundefs @ remove_mutrec defs + | def :: defs -> + def :: remove_mutrec defs + let to_ast (default_names : Nameset.t) (kind_env : kind Envmap.t) (def_ord : order) (Parse_ast.Defs(defs)) = + let defs = remove_mutrec defs in let defs,(_,k_env,def_ord),partial_defs = to_ast_defs_helper (default_names,kind_env,def_ord) [] defs in List.iter (fun (id,(d,k)) -> diff --git a/src/initial_check.mli b/src/initial_check.mli index feb9cb83..cfbea3e1 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -44,6 +44,7 @@ open Ast open Ast_util val opt_undefined_gen : bool ref +val opt_magic_hash : bool ref val process_ast : order -> Parse_ast.defs -> unit defs diff --git a/src/lexer2.mll b/src/lexer2.mll index 40e7eec6..a8dbaaf3 100644 --- a/src/lexer2.mll +++ b/src/lexer2.mll @@ -121,6 +121,7 @@ let kw_table = ("in", (fun x -> In)); ("inc", (fun _ -> Inc)); ("let", (fun x -> Let_)); + ("record", (fun _ -> Record)); ("Int", (fun x -> Int)); ("Order", (fun x -> Order)); ("pure", (fun x -> Pure)); @@ -142,6 +143,7 @@ let kw_table = ("until", (fun _ -> Until)); ("while", (fun _ -> While)); ("do", (fun _ -> Do)); + ("mutual", (fun _ -> Mutual)); ("barr", (fun x -> Barr)); ("depend", (fun x -> Depend)); @@ -169,7 +171,7 @@ let binarydigit = ['0'-'1'] let hexdigit = ['0'-'9''A'-'F''a'-'f'] let alphanum = letter|digit let startident = letter|'_' -let ident = alphanum|['_''\''] +let ident = alphanum|['_''\'''#'] let tyvar_start = '\'' let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''@''^''|'] let operator = (oper_char+ ('_' ident)?) @@ -200,6 +202,8 @@ rule token = parse | ";" { Semi } | "*" { (Star(r"*")) } | "_" { Under } + | "[|" { LsquareBar } + | "|]" { RsquareBar } | "{|" { LcurlyBar } | "|}" { RcurlyBar } | "|" { Bar } diff --git a/src/parse_ast.ml b/src/parse_ast.ml index bdf56cc8..aceba3b6 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -275,7 +275,7 @@ exp_aux = (* Expression *) | E_vector_append of exp * exp (* vector concatenation *) | E_list of (exp) list (* list *) | E_cons of exp * exp (* cons *) - | E_record of fexps (* struct *) + | E_record of exp list (* struct *) | E_record_update of exp * (exp) list (* functional update of struct *) | E_field of exp * id (* field projection from struct *) | E_case of exp * (pexp) list (* pattern matching *) @@ -498,6 +498,7 @@ def = (* Top-level definition *) | DEF_default of default_typing_spec (* default kind and type assumptions *) | DEF_scattered of scattered_def (* scattered definition *) | DEF_reg_dec of dec_spec (* register declaration *) + | DEF_internal_mutrec of fundef list type diff --git a/src/parser2.mly b/src/parser2.mly index a752e5c1..1444f6cd 100644 --- a/src/parser2.mly +++ b/src/parser2.mly @@ -142,13 +142,13 @@ let rec desugar_rchain chain s e = %token Pure Register Return Scattered Sizeof Struct Then True TwoCaret TYPE Typedef %token Undefined Union With Val Constraint Throw Try Catch Exit %token Barr Depend Rreg Wreg Rmem Rmemt Wmem Wmv Wmvt Eamem Exmem Undef Unspec Nondet Escape -%token Repeat Until While Do +%token Repeat Until While Do Record Mutual %nonassoc Then %nonassoc Else %token Bar Comma Dot Eof Minus Semi Under DotDot -%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar +%token Lcurly Rcurly Lparen Rparen Lsquare Rsquare LcurlyBar RcurlyBar LsquareBar RsquareBar %token MinusGt /*Terminals with content*/ @@ -957,17 +957,33 @@ atomic_exp: { mk_exp (E_vector_access ($1, $3)) $startpos $endpos } | atomic_exp Lsquare exp DotDot exp Rsquare { mk_exp (E_vector_subrange ($1, $3, $5)) $startpos $endpos } + | Record Lcurly fexp_exp_list Rcurly + { mk_exp (E_record $3) $startpos $endpos } + | Lcurly exp With fexp_exp_list Rcurly + { mk_exp (E_record_update ($2, $4)) $startpos $endpos } | Lsquare exp_list Rsquare { mk_exp (E_vector $2) $startpos $endpos } | Lsquare exp With atomic_exp Eq exp Rsquare { mk_exp (E_vector_update ($2, $4, $6)) $startpos $endpos } | Lsquare exp With atomic_exp DotDot atomic_exp Eq exp Rsquare { mk_exp (E_vector_update_subrange ($2, $4, $6, $8)) $startpos $endpos } + | LsquareBar exp_list RsquareBar + { mk_exp (E_list $2) $startpos $endpos } | Lparen exp Rparen { $2 } | Lparen exp Comma exp_list Rparen { mk_exp (E_tuple ($2 :: $4)) $startpos $endpos } +fexp_exp: + | atomic_exp Eq exp + { mk_exp (E_app_infix ($1, mk_id (Id "=") $startpos($2) $endpos($2), $3)) $startpos $endpos } + +fexp_exp_list: + | fexp_exp + { [$1] } + | fexp_exp Comma fexp_exp_list + { $1 :: $3 } + exp_list: | exp { [$1] } @@ -1042,6 +1058,12 @@ fun_def: | Function_ funcls { mk_fun (FD_function (mk_recn, mk_tannotn, mk_eannotn, $2)) $startpos $endpos } +fun_def_list: + | fun_def + { [$1] } + | fun_def fun_def_list + { $1 :: $2 } + let_def: | Let_ letbind { $2 } @@ -1115,6 +1137,8 @@ def: { DEF_scattered (mk_sd (SD_scattered_end $2) $startpos $endpos) } | default_def { DEF_default $1 } + | Mutual Lcurly fun_def_list Rcurly + { DEF_internal_mutrec $3 } defs_list: | def diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index 8c8b5661..8ebef0f0 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -183,12 +183,13 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" | E_cons (exp1, exp2) -> string "E_cons" - | E_record fexps -> string "E_record" + | E_record fexps -> separate space [string "record"; string "{"; doc_fexps fexps; string "}"] | E_loop (While, cond, exp) -> separate space [string "while"; doc_exp cond; string "do"; doc_exp exp] | E_loop (Until, cond, exp) -> separate space [string "repeat"; doc_exp exp; string "until"; doc_exp cond] - | E_record_update (exp, fexps) -> string "E_record_update" + | E_record_update (exp, fexps) -> + separate space [string "{"; doc_exp exp; string "with"; doc_fexps fexps; string "}"] | E_vector_append (exp1, exp2) -> separate space [doc_atomic_exp exp1; string "@"; doc_atomic_exp exp2] | E_case (exp, pexps) -> separate space [string "match"; doc_exp exp; doc_pexps pexps] @@ -245,6 +246,10 @@ and doc_atomic_exp (E_aux (e_aux, _) as exp) = | E_vector_update_subrange (exp1, exp2, exp3, exp4) -> brackets (separate space [doc_exp exp1; string "with"; doc_atomic_exp exp2; string ".."; doc_atomic_exp exp3; equals; doc_exp exp4]) | _ -> parens (doc_exp exp) +and doc_fexps (FES_aux (FES_Fexps (fexps, _), _)) = + separate_map (comma ^^ space) doc_fexp fexps +and doc_fexp (FE_aux (FE_Fexp (id, exp), _)) = + separate space [doc_id id; equals; doc_exp exp] and doc_block = function | [] -> string "()" | [E_aux (E_let (LB_aux (LB_val (pat, binding), _), E_aux (E_block exps, _)), _)] -> @@ -336,17 +341,7 @@ let doc_spec (VS_aux(v,_)) = let doc_backend b = Util.option_map (fun id -> string (b ^ ":") ^^ space ^^ utf8string ("\"" ^ String.escaped id ^ "\"")) (ext b) in let docs = Util.option_these (List.map doc_backend ["ocaml"; "lem"]) in - if docs = [] then empty else braces (separate (comma ^^ space) docs) - (* function - | Some s -> - let ext_for backend = utf8string ("\"" ^ String.escaped (s backend) ^ "\"") in - let extern = - if s "ocaml" = s "lem" - then ext_for "ocaml" - else separate space [lbrace; string "ocaml:"; ext_for "ocaml"; string "lem:"; ext_for "lem"; rbrace] - in - equals ^^ space ^^ extern ^^ space - | None -> empty *) + if docs = [] then empty else equals ^^ space ^^ braces (separate (comma ^^ space) docs) in match v with | VS_val_spec(ts,id,ext,is_cast) -> @@ -382,6 +377,9 @@ let rec doc_def def = group (match def with | DEF_kind k_def -> doc_kind_def k_def | DEF_fundef f_def -> doc_fundef f_def | DEF_val lbind -> string "let" ^^ space ^^ doc_letbind lbind + | DEF_internal_mutrec fundefs -> + (string "mutual {" ^//^ separate_map (hardline ^^ hardline) doc_fundef fundefs) + ^^ hardline ^^ string "}" | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef | DEF_fixity (prec, n, id) -> diff --git a/src/process_file.ml b/src/process_file.ml index 92b3f328..75e3092f 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -229,4 +229,5 @@ let rewrite_ast = rewrite [("initial", Rewriter.rewrite_defs)] let rewrite_undefined = rewrite [("undefined", fun x -> Rewrites.rewrite_undefined !opt_lem_mwords x)] let rewrite_ast_lem = rewrite Rewrites.rewrite_defs_lem let rewrite_ast_ocaml = rewrite Rewrites.rewrite_defs_ocaml +let rewrite_ast_sil = rewrite Rewrites.rewrite_defs_sil let rewrite_ast_check = rewrite Rewrites.rewrite_defs_check diff --git a/src/process_file.mli b/src/process_file.mli index b575bd14..116df06e 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -48,6 +48,7 @@ val rewrite_ast: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_undefined: Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_lem : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_ocaml : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs +val rewrite_ast_sil : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val rewrite_ast_check : Type_check.tannot Ast.defs -> Type_check.tannot Ast.defs val load_file_no_check : Ast.order -> string -> unit Ast.defs diff --git a/src/rewrites.ml b/src/rewrites.ml index 13d811e4..80e09e9a 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -2757,6 +2757,18 @@ let rewrite_defs_ocaml = [ (* ("separate_numbs", rewrite_defs_separate_numbs) *) ] +let rewrite_defs_sil = [ + ("top_sort_defs", top_sort_defs); + ("tuple_vector_assignments", rewrite_tuple_vector_assignments); + ("tuple_assignments", rewrite_tuple_assignments); + ("simple_assignments", rewrite_simple_assignments); + ("constraint", rewrite_constraint); + ("trivial_sizeof", rewrite_trivial_sizeof); + ("sizeof", rewrite_sizeof); + ("remove_vector_concat", rewrite_defs_remove_vector_concat); + ("remove_bitvector_pats", rewrite_defs_remove_bitvector_pats); + ] + let rewrite_check_annot = let check_annot exp = try diff --git a/src/rewrites.mli b/src/rewrites.mli index 628296ec..432a2bd8 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -53,6 +53,9 @@ val rewrite_defs_ocaml : (string * (tannot defs -> tannot defs)) list (* Perform rewrites to exclude AST nodes not supported for lem out*) val rewrite_defs_lem : (string * (tannot defs -> tannot defs)) list +(* Perform rewrites to sail intermediate language *) +val rewrite_defs_sil : (string * (tannot defs -> tannot defs)) list + (* This is a special rewriter pass that checks AST invariants without actually doing any re-writing *) val rewrite_defs_check : (string * (tannot defs -> tannot defs)) list diff --git a/src/sail.ml b/src/sail.ml index e7e965ba..dbd95f1d 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -49,6 +49,7 @@ let opt_print_initial_env = ref false let opt_print_verbose = ref false let opt_print_lem_ast = ref false let opt_print_lem = ref false +let opt_print_sil = ref false let opt_print_ocaml = ref false let opt_convert = ref false let opt_memo_z3 = ref false @@ -74,6 +75,9 @@ let options = Arg.align ([ ( "-lem_ast", Arg.Set opt_print_lem_ast, " output a Lem AST representation of the input"); + ( "-sil", + Arg.Tuple [Arg.Set opt_print_sil; Arg.Set Initial_check.opt_undefined_gen], + " output a SIL translated version of the input"); ( "-lem", Arg.Set opt_print_lem, " output a Lem translated version of the input"); @@ -138,6 +142,9 @@ let options = Arg.align ([ ( "-dsanity", Arg.Set opt_sanity, " (debug) sanity check the AST (slow)"); + ( "-dmagic_hash", + Arg.Set Initial_check.opt_magic_hash, + " (debug) allow special character # in identifiers"); ( "-v", Arg.Set opt_print_version, " print version"); @@ -204,6 +211,11 @@ let main() = (if !(opt_print_lem_ast) then output "" Lem_ast_out [out_name,ast] else ()); + (if !(opt_print_sil) + then + let ast = rewrite_ast_sil ast in + Pretty_print_sail2.pp_defs stdout ast + else ()); (if !(opt_print_ocaml) then let ast_ocaml = rewrite_ast_ocaml ast in -- cgit v1.2.3 From ff514f618bc64980e08d201ec971ccf38421e586 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Thu, 30 Nov 2017 20:33:07 +0000 Subject: Use doc_typdef_lem from experiments --- src/pretty_print_lem.ml | 80 ++++++++++++++++++++++++++----------------------- 1 file changed, 42 insertions(+), 38 deletions(-) (limited to 'src') diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index ef91c684..4b0091bd 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -1294,9 +1294,9 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with (concat [string "type"; space; doc_id_lem_type id; space; doc_typquant_items_lem None typq]) ((*doc_typquant_lem typq*) ar_doc) in let make_id pat id = - separate space [string "Interp_ast.Id_aux"; - parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "Interp_ast.Unknown"] in + separate space [string "SIA.Id_aux"; + parens (string "SIA.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "SIA.Unknown"] in let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let fromInterpValuePP = @@ -1308,18 +1308,18 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with match tu with | Tu_ty_id (ty,cid) -> (separate space) - [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid; parens (string "fromInterpValue v")] | Tu_id cid -> (separate space) - [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow; doc_id_lem_ctor cid]) ar) ^/^ - ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -1338,40 +1338,43 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with | Tu_ty_id (ty,cid) -> (separate space) [pipe;doc_id_lem_ctor cid;string "v";arrow; - string "Interp_ast.V_ctor"; + string "SI.V_ctor"; parens (make_id false cid); - parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); - string "Interp_ast.C_Union"; + parens (string "SIA.T_id " ^^ string_lit (doc_id id)); + string "SI.C_Union"; parens (string "toInterpValue v")] | Tu_id cid -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "Interp_ast.V_ctor"; + string "SI.V_ctor"; parens (make_id false cid); - parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); - string "Interp_ast.C_Union"; + parens (string "SIA.T_id " ^^ string_lit (doc_id id)); + string "SI.C_Union"; parens (string "toInterpValue ()")]) ar) ^/^ string "end") in let fromToInterpValuePP = - toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - (typ_pp ^^ hardline,fromToInterpValuePP ^^ hardline)) + typ_pp ^^ hardline ^^ hardline ^^ + if !print_to_from_interp_value then + toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ + fromToInterpValuePP ^^ hardline + else empty) | TD_enum(id,nm,enums,_) -> (match id with - | Id_aux ((Id "read_kind"),_) -> (empty,empty) - | Id_aux ((Id "write_kind"),_) -> (empty,empty) - | Id_aux ((Id "barrier_kind"),_) -> (empty,empty) - | Id_aux ((Id "trans_kind"),_) -> (empty,empty) - | Id_aux ((Id "instruction_kind"),_) -> (empty,empty) - | Id_aux ((Id "regfp"),_) -> (empty,empty) - | Id_aux ((Id "niafp"),_) -> (empty,empty) - | Id_aux ((Id "diafp"),_) -> (empty,empty) + | Id_aux ((Id "read_kind"),_) -> empty + | Id_aux ((Id "write_kind"),_) -> empty + | Id_aux ((Id "barrier_kind"),_) -> empty + | Id_aux ((Id "trans_kind"),_) -> empty + | Id_aux ((Id "instruction_kind"),_) -> empty + | Id_aux ((Id "regfp"),_) -> empty + | Id_aux ((Id "niafp"),_) -> empty + | Id_aux ((Id "diafp"),_) -> empty | _ -> let rec range i j = if i > j then [] else i :: (range (i+1) j) in let nats = range 0 in @@ -1382,9 +1385,9 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with let fromInterpValueF = concat [doc_id_lem_type id;string "FromInterpValue"] in let toInterpValueF = concat [doc_id_lem_type id;string "ToInterpValue"] in let make_id pat id = - separate space [string "Interp_ast.Id_aux"; - parens (string "Interp_ast.Id " ^^ string_lit (doc_id id)); - if pat then underscore else string "Interp_ast.Unknown"] in + separate space [string "SIA.Id_aux"; + parens (string "SIA.Id " ^^ string_lit (doc_id id)); + if pat then underscore else string "SIA.Unknown"] in let fromInterpValuePP = (prefix 2 1) (separate space [string "let rec";fromInterpValueF;string "v";equals;string "match v with"]) @@ -1392,7 +1395,7 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with ((separate_map (break 1)) (fun (cid) -> (separate space) - [pipe;string "Interp_ast.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; + [pipe;string "SI.V_ctor";parens (make_id true cid);underscore;underscore;string "v"; arrow;doc_id_lem_ctor cid] ) enums @@ -1400,7 +1403,7 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with ( (align ((prefix 3 1) - (separate space [pipe;string ("Interp_ast.V_lit (Interp_ast.L_aux (Interp_ast.L_num n) _)");arrow]) + (separate space [pipe;string ("SI.V_lit (SIA.L_aux (SIA.L_num n) _)");arrow]) (separate space [string "match";parens(string "natFromInteger n");string "with"] ^/^ ( ((separate_map (break 1)) @@ -1416,7 +1419,7 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with ) ) ^/^ - ((separate space) [pipe;string "Interp_ast.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ + ((separate space) [pipe;string "SI.V_tuple [v]";arrow;fromInterpValueF;string "v"]) ^/^ let failmessage = (string_lit @@ -1434,25 +1437,27 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with (fun (cid,number) -> (separate space) [pipe;doc_id_lem_ctor cid;arrow; - string "Interp_ast.V_ctor"; + string "SI.V_ctor"; parens (make_id false cid); - parens (string "Interp_ast.T_id " ^^ string_lit (doc_id id)); - parens (string ("Interp_ast.C_Enum " ^ string_of_int number)); + parens (string "SIA.T_id " ^^ string_lit (doc_id id)); + parens (string ("SI.C_Enum " ^ string_of_int number)); parens (string "toInterpValue ()")]) (List.combine enums (nats ((List.length enums) - 1)))) ^/^ string "end") in let fromToInterpValuePP = - toInterpValuePP ^^ hardline ^^ hardline ^^ - fromInterpValuePP ^^ hardline ^^ hardline ^^ ((prefix 2 1) (concat [string "instance ";parens (string "ToFromInterpValue " ^^ doc_id_lem_type id)]) (concat [string "let toInterpValue = ";toInterpValueF;hardline; string "let fromInterpValue = ";fromInterpValueF])) ^/^ string "end" in - (typ_pp ^^ hardline, - fromToInterpValuePP ^^ hardline)) + typ_pp ^^ hardline ^^ hardline ^^ + if !print_to_from_interp_value + then toInterpValuePP ^^ hardline ^^ hardline ^^ + fromInterpValuePP ^^ hardline ^^ hardline ^^ + fromToInterpValuePP ^^ hardline + else empty) | TD_register(id,n1,n2,rs) -> - match n1,n2 with + match n1, n2 with | Nexp_aux(Nexp_constant i1,_),Nexp_aux(Nexp_constant i2,_) -> let dir_b = i1 < i2 in let dir = (if dir_b then "true" else "false") in @@ -1533,7 +1538,6 @@ let doc_typdef_lem sequential mwords (TD_aux(td, (l, annot))) = match td with separate_map hardline doc_field rs*) | _ -> raise (Reporting_basic.err_unreachable l "register with non-constant indices") - let doc_rec_lem (Rec_aux(r,_)) = match r with | Rec_nonrec -> space | Rec_rec -> space ^^ string "rec" ^^ space -- cgit v1.2.3 From d9f2fa400731d007ed2874f37ff8d8a649b73a9d Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Mon, 4 Dec 2017 15:35:05 +0000 Subject: Fix warnings in test suite --- src/lexer.mll | 2 +- src/pre_lexer.mll | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/lexer.mll b/src/lexer.mll index 3b1a1583..1443e94d 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -157,7 +157,7 @@ let binarydigit = ['0'-'1'] let hexdigit = ['0'-'9''A'-'F''a'-'f'] let alphanum = letter|digit let startident = letter|'_' -let ident = alphanum|['_''\''] +let ident = alphanum|['_''\'''#'] let tyvar_start = '\'' let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''?''@''^''|''~'] let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) diff --git a/src/pre_lexer.mll b/src/pre_lexer.mll index f648a594..7e119118 100644 --- a/src/pre_lexer.mll +++ b/src/pre_lexer.mll @@ -118,7 +118,7 @@ let binarydigit = ['0'-'1'] let hexdigit = ['0'-'9''A'-'F''a'-'f'] let alphanum = letter|digit let startident = letter|'_' -let ident = alphanum|['_''\''] +let ident = alphanum|['_''\'''#'] let tyvar_start = '\'' let oper_char = ['!''$''%''&''*''+''-''.''/'':''<''=''>''?''@''^''|''~'] let escape_sequence = ('\\' ['\\''\"''\'''n''t''b''r']) | ('\\' digit digit digit) | ('\\' 'x' hexdigit hexdigit) -- cgit v1.2.3 From 7387aaa375859cd0fe090ba1df77972a7179e79f Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 5 Dec 2017 15:50:53 +0000 Subject: Pretty printer now prints operator precedence correctly. Also some simple rules to try to format if statements better based on contents while pretty printing. --- src/pretty_print_sail2.ml | 72 ++++++++++++++++++++++++++++++++++++++++++++++- src/type_check.ml | 5 ++-- 2 files changed, 73 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index 8ebef0f0..cde40c4f 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -169,18 +169,68 @@ let rec doc_pat (P_aux (p_aux, _) as pat) = | P_app (id, pats) -> doc_id id ^^ parens (separate_map (comma ^^ space) doc_pat pats) | _ -> string (string_of_pat pat) +(* if_block_x is true if x should be printed like a block, i.e. with + newlines. Blocks are automatically printed as blocks, so this + returns false for them. *) +let if_block_then (E_aux (e_aux, _)) = + match e_aux with + | E_assign _ | E_if _ -> true + | _ -> false + +let if_block_else (E_aux (e_aux, _)) = + match e_aux with + | E_assign _ -> true + | _ -> false + +let fixities = + let fixities' = + List.fold_left + (fun r (x, y) -> Bindings.add x y r) + Bindings.empty + [ + (mk_id "^", (InfixR, 8)); + (mk_id "*", (InfixL, 7)); + (mk_id "+", (InfixL, 6)); + (mk_id "-", (InfixL, 6)); + (mk_id "!=", (Infix, 4)); + (mk_id ">", (Infix, 4)); + (mk_id "<", (Infix, 4)); + (mk_id ">=", (Infix, 4)); + (mk_id "<=", (Infix, 4)); + (mk_id "&", (InfixR, 3)); + (mk_id "|", (InfixR, 2)); + ] + in + ref (fixities' : (prec * int) Bindings.t) + let rec doc_exp (E_aux (e_aux, _) as exp) = match e_aux with + | E_block [] -> string "()" | E_block [exp] -> doc_exp exp | E_block exps -> surround 2 0 lbrace (doc_block exps) rbrace | E_nondet exps -> assert false (* This is mostly for the -convert option *) | E_app_infix (x, id, y) when Id.compare (mk_id "quot") id == 0 -> separate space [doc_atomic_exp x; string "/"; doc_atomic_exp y] - | E_app_infix (x, id, y) -> separate space [doc_atomic_exp x; doc_id id; doc_atomic_exp y] + | E_app_infix _ -> doc_infix 0 exp | E_tuple exps -> parens (separate_map (comma ^^ space) doc_exp exps) + + (* Various rules to try to format if blocks nicely based on content *) + | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp && if_block_else else_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^//^ doc_exp else_exp) + | E_if (if_exp, then_exp, (E_aux (E_if _, _) as else_exp)) when if_block_then then_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^^ space ^^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) when if_block_else else_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp]) + ^^ space ^^ (string "else" ^//^ doc_exp else_exp) + | E_if (if_exp, then_exp, else_exp) when if_block_then then_exp -> + (separate space [string "if"; doc_exp if_exp; string "then"] ^//^ doc_exp then_exp) + ^/^ (string "else" ^^ space ^^ doc_exp else_exp) | E_if (if_exp, then_exp, else_exp) -> group (separate space [string "if"; doc_exp if_exp; string "then"; doc_exp then_exp; string "else"; doc_exp else_exp]) + | E_list exps -> string "[|" ^^ separate_map (comma ^^ space) doc_exp exps ^^ string "|]" | E_cons (exp1, exp2) -> string "E_cons" | E_record fexps -> separate space [string "record"; string "{"; doc_fexps fexps; string "}"] @@ -222,6 +272,24 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> separate space [string "2"; string "^"; doc_atomic_exp exp] | _ -> doc_atomic_exp exp +and doc_infix n (E_aux (e_aux, _) as exp) = + match e_aux with + | E_app_infix (l, op, r) when n < 10 -> + let module M = Map.Make(String) in + begin + try + match Bindings.find op !fixities with + | (Infix, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r] + | (Infix, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix (m + 1) r]) + | (InfixL, m) when m >= n -> separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r] + | (InfixL, m) when m < n -> parens (separate space [doc_infix m l; doc_id op; doc_infix (m + 1) r]) + | (InfixR, m) when m >= n -> separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r] + | (InfixR, m) when m < n -> parens (separate space [doc_infix (m + 1) l; doc_id op; doc_infix m r]) + with + | Not_found -> + separate space [doc_atomic_exp l; doc_id op; doc_atomic_exp r] + end + | _ -> doc_atomic_exp exp and doc_atomic_exp (E_aux (e_aux, _) as exp) = match e_aux with | E_cast (typ, exp) -> @@ -383,6 +451,8 @@ let rec doc_def def = group (match def with | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef | DEF_fixity (prec, n, id) -> + print_endline ("YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY " ^ string_of_id id); + fixities := Bindings.add id (prec, int_of_big_int n) !fixities; separate space [doc_prec prec; doc_int n; doc_id id] | DEF_overload (id, ids) -> separate space [string "overload"; doc_id id; equals; surround 2 0 lbrace (separate_map (comma ^^ break 1) doc_id ids) rbrace] diff --git a/src/type_check.ml b/src/type_check.ml index 6c158f9e..7ec677f6 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -379,7 +379,7 @@ end = struct default_order : order option; ret_typ : typ option; poly_undefineds : bool; - prove : t -> n_constraint -> bool + prove : t -> n_constraint -> bool; } let empty = @@ -405,7 +405,7 @@ end = struct default_order = None; ret_typ = None; poly_undefineds = false; - prove = (fun _ _ -> false) + prove = (fun _ _ -> false); } let add_prover f env = { env with prove = f } @@ -936,7 +936,6 @@ end = struct { env with poly_undefineds = true } let polymorphic_undefineds env = env.poly_undefineds - end -- cgit v1.2.3 From 631373a7694db8a789a7d9efbdcf16d17aa1ce98 Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 5 Dec 2017 15:57:30 +0000 Subject: Update license headers for Sail source --- src/LICENCE | 10 ++++++- src/Makefile | 8 +++++ src/Makefile-non-opam | 8 +++++ src/ast_util.ml | 6 ++++ src/ast_util.mli | 6 ++++ src/constraint.ml | 50 ++++++++++++++++++++++++++++++++ src/constraint.mli | 50 ++++++++++++++++++++++++++++++++ src/finite_map.ml | 8 +++++ src/initial_check.ml | 8 +++++ src/initial_check.mli | 8 +++++ src/lem_interp/instruction_extractor.lem | 8 +++++ src/lem_interp/interp.lem | 8 +++++ src/lem_interp/interp_inter_imp.lem | 8 +++++ src/lem_interp/interp_interface.lem | 8 +++++ src/lem_interp/interp_lib.lem | 8 +++++ src/lem_interp/interp_utilities.lem | 8 +++++ src/lem_interp/pretty_interp.ml | 8 +++++ src/lem_interp/printing_functions.ml | 8 +++++ src/lem_interp/run_interp.ml | 8 +++++ src/lem_interp/run_interp_model.ml | 8 +++++ src/lem_interp/run_with_elf.ml | 8 +++++ src/lem_interp/run_with_elf_cheri.ml | 8 +++++ src/lem_interp/run_with_elf_cheri128.ml | 8 +++++ src/lem_interp/sail_impl_base.lem | 8 +++++ src/lexer.mll | 8 +++++ src/lexer2.mll | 8 +++++ src/monomorphise.ml | 50 ++++++++++++++++++++++++++++++++ src/myocamlbuild.ml | 8 +++++ src/ocaml_backend.ml | 50 ++++++++++++++++++++++++++++++++ src/parse_ast.ml | 8 +++++ src/parser.mly | 8 +++++ src/parser2.mly | 8 +++++ src/pp.ml | 8 +++++ src/pp.mli | 8 +++++ src/pre_lexer.mll | 8 +++++ src/pre_parser.mly | 8 +++++ src/pretty_print.ml | 8 +++++ src/pretty_print.mli | 8 +++++ src/pretty_print_common.ml | 8 +++++ src/pretty_print_lem.ml | 7 +++++ src/pretty_print_lem_ast.ml | 8 +++++ src/pretty_print_sail.ml | 8 +++++ src/pretty_print_sail2.ml | 49 +++++++++++++++++++++++++++++++ src/process_file.ml | 8 +++++ src/process_file.mli | 8 +++++ src/reporting_basic.ml | 8 +++++ src/reporting_basic.mli | 8 +++++ src/rewriter.ml | 7 +++++ src/rewriter.mli | 7 +++++ src/rewrites.ml | 7 +++++ src/rewrites.mli | 7 +++++ src/sail.ml | 8 +++++ src/spec_analysis.ml | 8 +++++ src/spec_analysis.mli | 8 +++++ src/type_check.ml | 7 +++++ src/type_check.mli | 7 +++++ src/util.ml | 8 +++++ src/util.mli | 8 +++++ 58 files changed, 663 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/LICENCE b/src/LICENCE index 5992fbfc..6b6dcc4f 100644 --- a/src/LICENCE +++ b/src/LICENCE @@ -1,6 +1,6 @@ Sail -Copyright (c) 2013-2017 +Copyright (c) 2013-2017 Kathyrn Gray Shaked Flur Stephen Kell @@ -8,6 +8,14 @@ Copyright (c) 2013-2017 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. diff --git a/src/Makefile b/src/Makefile index e0c1e45c..abf03c4f 100644 --- a/src/Makefile +++ b/src/Makefile @@ -9,6 +9,14 @@ # 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. # # # diff --git a/src/Makefile-non-opam b/src/Makefile-non-opam index 18fe6aa4..ebd82c09 100644 --- a/src/Makefile-non-opam +++ b/src/Makefile-non-opam @@ -9,6 +9,14 @@ # 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. # # # diff --git a/src/ast_util.ml b/src/ast_util.ml index d2712133..450aa839 100644 --- a/src/ast_util.ml +++ b/src/ast_util.ml @@ -10,7 +10,13 @@ (* Christopher Pulte *) (* Peter Sewell *) (* Alasdair Armstrong *) +(* Brian Campbell *) (* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) (* *) (* All rights reserved. *) (* *) diff --git a/src/ast_util.mli b/src/ast_util.mli index 8206637c..3731c2f5 100644 --- a/src/ast_util.mli +++ b/src/ast_util.mli @@ -10,7 +10,13 @@ (* Christopher Pulte *) (* Peter Sewell *) (* Alasdair Armstrong *) +(* Brian Campbell *) (* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) (* *) (* All rights reserved. *) (* *) diff --git a/src/constraint.ml b/src/constraint.ml index 37073ff2..3d5a3689 100644 --- a/src/constraint.ml +++ b/src/constraint.ml @@ -1,3 +1,53 @@ +(**************************************************************************) +(* 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 Big_int open Util diff --git a/src/constraint.mli b/src/constraint.mli index 33881fcf..89f2c625 100644 --- a/src/constraint.mli +++ b/src/constraint.mli @@ -1,3 +1,53 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + type nexp type t diff --git a/src/finite_map.ml b/src/finite_map.ml index 411048b6..444e3790 100644 --- a/src/finite_map.ml +++ b/src/finite_map.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/initial_check.ml b/src/initial_check.ml index 2764c30b..21e27ac9 100644 --- a/src/initial_check.ml +++ b/src/initial_check.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/initial_check.mli b/src/initial_check.mli index cfbea3e1..e39c7427 100644 --- a/src/initial_check.mli +++ b/src/initial_check.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/instruction_extractor.lem b/src/lem_interp/instruction_extractor.lem index 056f0100..b49646ea 100644 --- a/src/lem_interp/instruction_extractor.lem +++ b/src/lem_interp/instruction_extractor.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/interp.lem b/src/lem_interp/interp.lem index cc10b758..486728d9 100644 --- a/src/lem_interp/interp.lem +++ b/src/lem_interp/interp.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/interp_inter_imp.lem b/src/lem_interp/interp_inter_imp.lem index c982a30a..563da2e5 100644 --- a/src/lem_interp/interp_inter_imp.lem +++ b/src/lem_interp/interp_inter_imp.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/interp_interface.lem b/src/lem_interp/interp_interface.lem index 07d9e2b3..32744da2 100644 --- a/src/lem_interp/interp_interface.lem +++ b/src/lem_interp/interp_interface.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/interp_lib.lem b/src/lem_interp/interp_lib.lem index 40dbab88..e55fc175 100644 --- a/src/lem_interp/interp_lib.lem +++ b/src/lem_interp/interp_lib.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/interp_utilities.lem b/src/lem_interp/interp_utilities.lem index 1878066f..a178df61 100644 --- a/src/lem_interp/interp_utilities.lem +++ b/src/lem_interp/interp_utilities.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/pretty_interp.ml b/src/lem_interp/pretty_interp.ml index 950e1ac5..129b74c0 100644 --- a/src/lem_interp/pretty_interp.ml +++ b/src/lem_interp/pretty_interp.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/printing_functions.ml b/src/lem_interp/printing_functions.ml index a19256a2..a096b27b 100644 --- a/src/lem_interp/printing_functions.ml +++ b/src/lem_interp/printing_functions.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/run_interp.ml b/src/lem_interp/run_interp.ml index f61d9aaf..a6910024 100644 --- a/src/lem_interp/run_interp.ml +++ b/src/lem_interp/run_interp.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/run_interp_model.ml b/src/lem_interp/run_interp_model.ml index 81f0a5fd..bb02ce1e 100644 --- a/src/lem_interp/run_interp_model.ml +++ b/src/lem_interp/run_interp_model.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/run_with_elf.ml b/src/lem_interp/run_with_elf.ml index 98b98a03..8533827b 100644 --- a/src/lem_interp/run_with_elf.ml +++ b/src/lem_interp/run_with_elf.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/run_with_elf_cheri.ml b/src/lem_interp/run_with_elf_cheri.ml index 7750c16c..46bc92fb 100644 --- a/src/lem_interp/run_with_elf_cheri.ml +++ b/src/lem_interp/run_with_elf_cheri.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/run_with_elf_cheri128.ml b/src/lem_interp/run_with_elf_cheri128.ml index 6dca80f4..5e5bee21 100644 --- a/src/lem_interp/run_with_elf_cheri128.ml +++ b/src/lem_interp/run_with_elf_cheri128.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lem_interp/sail_impl_base.lem b/src/lem_interp/sail_impl_base.lem index 59e86ece..ba1eac0e 100644 --- a/src/lem_interp/sail_impl_base.lem +++ b/src/lem_interp/sail_impl_base.lem @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lexer.mll b/src/lexer.mll index 1443e94d..35ab6627 100644 --- a/src/lexer.mll +++ b/src/lexer.mll @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/lexer2.mll b/src/lexer2.mll index a8dbaaf3..e43bd3e1 100644 --- a/src/lexer2.mll +++ b/src/lexer2.mll @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/monomorphise.ml b/src/monomorphise.ml index 7774e110..6350f511 100644 --- a/src/monomorphise.ml +++ b/src/monomorphise.ml @@ -1,3 +1,53 @@ +(**************************************************************************) +(* 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 Parse_ast open Ast open Ast_util diff --git a/src/myocamlbuild.ml b/src/myocamlbuild.ml index 697ee9bd..a437e7e6 100644 --- a/src/myocamlbuild.ml +++ b/src/myocamlbuild.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 333505e0..73a297ce 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -1,3 +1,53 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) + open Ast open Ast_util open PPrint diff --git a/src/parse_ast.ml b/src/parse_ast.ml index aceba3b6..705c7ff4 100644 --- a/src/parse_ast.ml +++ b/src/parse_ast.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/parser.mly b/src/parser.mly index 2cfa8e80..58f5f1e1 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -9,6 +9,14 @@ /* 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. */ /* */ diff --git a/src/parser2.mly b/src/parser2.mly index 1444f6cd..6ab070b7 100644 --- a/src/parser2.mly +++ b/src/parser2.mly @@ -9,6 +9,14 @@ /* 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. */ /* */ diff --git a/src/pp.ml b/src/pp.ml index 7da8aad3..b3eaf1fc 100644 --- a/src/pp.ml +++ b/src/pp.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pp.mli b/src/pp.mli index 0613e433..5cfb3d88 100644 --- a/src/pp.mli +++ b/src/pp.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pre_lexer.mll b/src/pre_lexer.mll index 7e119118..3c308b99 100644 --- a/src/pre_lexer.mll +++ b/src/pre_lexer.mll @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pre_parser.mly b/src/pre_parser.mly index b595d55d..0b4833a1 100644 --- a/src/pre_parser.mly +++ b/src/pre_parser.mly @@ -9,6 +9,14 @@ /* 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. */ /* */ diff --git a/src/pretty_print.ml b/src/pretty_print.ml index f778fe08..8047ff32 100644 --- a/src/pretty_print.ml +++ b/src/pretty_print.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pretty_print.mli b/src/pretty_print.mli index b878d29e..d411815f 100644 --- a/src/pretty_print.mli +++ b/src/pretty_print.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pretty_print_common.ml b/src/pretty_print_common.ml index 315772a4..bad03034 100644 --- a/src/pretty_print_common.ml +++ b/src/pretty_print_common.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pretty_print_lem.ml b/src/pretty_print_lem.ml index 4b0091bd..2df6d73d 100644 --- a/src/pretty_print_lem.ml +++ b/src/pretty_print_lem.ml @@ -9,7 +9,14 @@ (* 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. *) (* *) diff --git a/src/pretty_print_lem_ast.ml b/src/pretty_print_lem_ast.ml index 65fa5d25..506fac3b 100644 --- a/src/pretty_print_lem_ast.ml +++ b/src/pretty_print_lem_ast.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pretty_print_sail.ml b/src/pretty_print_sail.ml index e585a8f1..4ef506c5 100644 --- a/src/pretty_print_sail.ml +++ b/src/pretty_print_sail.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index cde40c4f..43c8eca9 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -1,3 +1,52 @@ +(**************************************************************************) +(* Sail *) +(* *) +(* Copyright (c) 2013-2017 *) +(* Kathyrn Gray *) +(* Shaked Flur *) +(* Stephen Kell *) +(* Gabriel Kerneis *) +(* Robert Norton-Wright *) +(* Christopher Pulte *) +(* Peter Sewell *) +(* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) +(* *) +(* All rights reserved. *) +(* *) +(* This software was developed by the University of Cambridge Computer *) +(* Laboratory as part of the Rigorous Engineering of Mainstream Systems *) +(* (REMS) project, funded by EPSRC grant EP/K008528/1. *) +(* *) +(* Redistribution and use in source and binary forms, with or without *) +(* modification, are permitted provided that the following conditions *) +(* are met: *) +(* 1. Redistributions of source code must retain the above copyright *) +(* notice, this list of conditions and the following disclaimer. *) +(* 2. Redistributions in binary form must reproduce the above copyright *) +(* notice, this list of conditions and the following disclaimer in *) +(* the documentation and/or other materials provided with the *) +(* distribution. *) +(* *) +(* THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' *) +(* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED *) +(* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A *) +(* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR *) +(* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, *) +(* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT *) +(* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF *) +(* USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND *) +(* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, *) +(* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT *) +(* OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF *) +(* SUCH DAMAGE. *) +(**************************************************************************) open Ast open Ast_util diff --git a/src/process_file.ml b/src/process_file.ml index 75e3092f..2d2cbe76 100644 --- a/src/process_file.ml +++ b/src/process_file.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/process_file.mli b/src/process_file.mli index 116df06e..f99bdf54 100644 --- a/src/process_file.mli +++ b/src/process_file.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/reporting_basic.ml b/src/reporting_basic.ml index a47ee8ae..166e0517 100644 --- a/src/reporting_basic.ml +++ b/src/reporting_basic.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/reporting_basic.mli b/src/reporting_basic.mli index 3d1cbe13..d2978389 100644 --- a/src/reporting_basic.mli +++ b/src/reporting_basic.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/rewriter.ml b/src/rewriter.ml index c483cf9b..98ecc486 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -9,7 +9,14 @@ (* 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. *) (* *) diff --git a/src/rewriter.mli b/src/rewriter.mli index 514ed034..9fa17a53 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -9,7 +9,14 @@ (* 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. *) (* *) diff --git a/src/rewrites.ml b/src/rewrites.ml index 80e09e9a..8963d189 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -9,7 +9,14 @@ (* 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. *) (* *) diff --git a/src/rewrites.mli b/src/rewrites.mli index 432a2bd8..ce24a4c4 100644 --- a/src/rewrites.mli +++ b/src/rewrites.mli @@ -9,7 +9,14 @@ (* 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. *) (* *) diff --git a/src/sail.ml b/src/sail.ml index dbd95f1d..aecbcbec 100644 --- a/src/sail.ml +++ b/src/sail.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/spec_analysis.ml b/src/spec_analysis.ml index bdbc031a..2fbe7e9d 100644 --- a/src/spec_analysis.ml +++ b/src/spec_analysis.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/spec_analysis.mli b/src/spec_analysis.mli index 6295a7ec..f13dd596 100644 --- a/src/spec_analysis.mli +++ b/src/spec_analysis.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/type_check.ml b/src/type_check.ml index 7ec677f6..8722f9d9 100644 --- a/src/type_check.ml +++ b/src/type_check.ml @@ -10,6 +10,13 @@ (* Christopher Pulte *) (* Peter Sewell *) (* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) (* *) (* All rights reserved. *) (* *) diff --git a/src/type_check.mli b/src/type_check.mli index 355740dc..5565c357 100644 --- a/src/type_check.mli +++ b/src/type_check.mli @@ -10,6 +10,13 @@ (* Christopher Pulte *) (* Peter Sewell *) (* Alasdair Armstrong *) +(* Brian Campbell *) +(* Thomas Bauereiss *) +(* Anthony Fox *) +(* Jon French *) +(* Dominic Mulligan *) +(* Stephen Kell *) +(* Mark Wassell *) (* *) (* All rights reserved. *) (* *) diff --git a/src/util.ml b/src/util.ml index 4f7878c7..6f7d6a95 100644 --- a/src/util.ml +++ b/src/util.ml @@ -9,6 +9,14 @@ (* 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. *) (* *) diff --git a/src/util.mli b/src/util.mli index 38af1fc2..b2ccf315 100644 --- a/src/util.mli +++ b/src/util.mli @@ -9,6 +9,14 @@ (* 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. *) (* *) -- cgit v1.2.3 From 44e9396fa90ab68ee4c8d9674c6bbad6fc851c6d Mon Sep 17 00:00:00 2001 From: Alasdair Armstrong Date: Tue, 5 Dec 2017 20:00:26 +0000 Subject: Better support for exceptions in sail for ASL specs that need them. --- src/ocaml_backend.ml | 15 +++++++++++++++ src/parser2.mly | 2 ++ src/pretty_print_sail2.ml | 4 +--- src/rewriter.ml | 4 ++++ src/rewriter.mli | 1 + src/rewrites.ml | 1 + 6 files changed, 24 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/ocaml_backend.ml b/src/ocaml_backend.ml index 73a297ce..6254d580 100644 --- a/src/ocaml_backend.ml +++ b/src/ocaml_backend.ml @@ -141,6 +141,7 @@ let ocaml_typ_id ctx = function | id when Id.compare id (mk_id "bool") = 0 -> string "bool" | id when Id.compare id (mk_id "unit") = 0 -> string "unit" | id when Id.compare id (mk_id "real") = 0 -> string "Num.num" + | id when Id.compare id (mk_id "exception") = 0 -> string "exn" | id when Id.compare id (mk_id "register") = 0 -> string "ref" | id -> zencode ctx id @@ -229,6 +230,7 @@ let rec ocaml_exp ctx (E_aux (exp_aux, _) as exp) = | E_block exps -> begin_end (ocaml_block ctx exps) | E_field (exp, id) -> ocaml_atomic_exp ctx exp ^^ dot ^^ zencode ctx id | E_exit exp -> string "exit 0" + | E_throw exp -> string "raise" ^^ space ^^ ocaml_atomic_exp ctx exp | E_case (exp, pexps) -> begin_end (separate space [string "match"; ocaml_atomic_exp ctx exp; string "with"] ^/^ ocaml_pexps ctx pexps) @@ -487,6 +489,17 @@ let rec ocaml_cases ctx = | tu :: tus -> ocaml_case tu ^/^ ocaml_cases ctx tus | [] -> empty +let rec ocaml_exceptions ctx = + let ocaml_exception = function + | Tu_aux (Tu_id id, _) -> separate space [string "exception"; zencode_upper ctx id] + | Tu_aux (Tu_ty_id (typ, id), _) -> + separate space [string "exception"; zencode_upper ctx id; string "of"; ocaml_typ ctx typ] + in + function + | [tu] -> ocaml_exception tu + | tu :: tus -> ocaml_exception tu ^^ string ";;" ^^ hardline ^^ ocaml_exceptions ctx tus + | [] -> empty + let rec ocaml_enum ctx = function | [id] -> zencode_upper ctx id | id :: ids -> zencode_upper ctx id ^/^ (bar ^^ space ^^ ocaml_enum ctx ids) @@ -524,6 +537,8 @@ let ocaml_typedef ctx (TD_aux (td_aux, _)) = ^/^ rbrace) ^^ ocaml_def_end ^^ ocaml_string_of_struct ctx id typq fields + | TD_variant (id, _, _, cases, _) when string_of_id id = "exception" -> + ocaml_exceptions ctx cases | TD_variant (id, _, typq, cases, _) -> separate space [string "type"; ocaml_typquant typq; zencode ctx id; equals] ^//^ ocaml_cases ctx cases diff --git a/src/parser2.mly b/src/parser2.mly index 6ab070b7..21959cf5 100644 --- a/src/parser2.mly +++ b/src/parser2.mly @@ -1021,6 +1021,8 @@ type_def: { mk_td (TD_enum ($2, mk_namesectn, $4, false)) $startpos $endpos } | Enum id Eq Lcurly enum Rcurly { mk_td (TD_enum ($2, mk_namesectn, $5, false)) $startpos $endpos } + | Union id Eq Lcurly type_unions Rcurly + { mk_td (TD_variant ($2, mk_namesectn, TypQ_aux (TypQ_tq [], loc $endpos($2) $startpos($3)), $5, false)) $startpos $endpos } | Union id typquant Eq Lcurly type_unions Rcurly { mk_td (TD_variant ($2, mk_namesectn, $3, $6, false)) $startpos $endpos } diff --git a/src/pretty_print_sail2.ml b/src/pretty_print_sail2.ml index 43c8eca9..82d3878b 100644 --- a/src/pretty_print_sail2.ml +++ b/src/pretty_print_sail2.ml @@ -315,7 +315,7 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = | _ -> header ^//^ doc_exp exp4 end (* Resugar an assert with an empty message *) - | E_throw exp -> assert false + | E_throw exp -> string "throw" ^^ parens (doc_exp exp) | E_try (exp, pexps) -> assert false | E_return exp -> string "return" ^^ parens (doc_exp exp) | E_app (id, [exp]) when Id.compare (mk_id "pow2") id == 0 -> @@ -324,7 +324,6 @@ let rec doc_exp (E_aux (e_aux, _) as exp) = and doc_infix n (E_aux (e_aux, _) as exp) = match e_aux with | E_app_infix (l, op, r) when n < 10 -> - let module M = Map.Make(String) in begin try match Bindings.find op !fixities with @@ -500,7 +499,6 @@ let rec doc_def def = group (match def with | DEF_reg_dec dec -> doc_dec dec | DEF_scattered sdef -> doc_scattered sdef | DEF_fixity (prec, n, id) -> - print_endline ("YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY " ^ string_of_id id); fixities := Bindings.add id (prec, int_of_big_int n) !fixities; separate space [doc_prec prec; doc_int n; doc_id id] | DEF_overload (id, ids) -> diff --git a/src/rewriter.ml b/src/rewriter.ml index 98ecc486..4683d84b 100644 --- a/src/rewriter.ml +++ b/src/rewriter.ml @@ -518,6 +518,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_sizeof : nexp -> 'exp_aux ; e_constraint : n_constraint -> 'exp_aux ; e_exit : 'exp -> 'exp_aux + ; e_throw : 'exp -> 'exp_aux ; e_return : 'exp -> 'exp_aux ; e_assert : 'exp * 'exp -> 'exp_aux ; e_internal_cast : 'a annot * 'exp -> 'exp_aux @@ -586,6 +587,7 @@ let rec fold_exp_aux alg = function | E_sizeof nexp -> alg.e_sizeof nexp | E_constraint nc -> alg.e_constraint nc | E_exit e -> alg.e_exit (fold_exp alg e) + | E_throw e -> alg.e_throw (fold_exp alg e) | E_return e -> alg.e_return (fold_exp alg e) | E_assert(e1,e2) -> alg.e_assert (fold_exp alg e1, fold_exp alg e2) | E_internal_cast (annot,e) -> alg.e_internal_cast (annot, fold_exp alg e) @@ -658,6 +660,7 @@ let id_exp_alg = ; e_sizeof = (fun nexp -> E_sizeof nexp) ; e_constraint = (fun nc -> E_constraint nc) ; e_exit = (fun e1 -> E_exit (e1)) + ; e_throw = (fun e1 -> E_throw (e1)) ; e_return = (fun e1 -> E_return e1) ; e_assert = (fun (e1,e2) -> E_assert(e1,e2)) ; e_internal_cast = (fun (a,e1) -> E_internal_cast (a,e1)) @@ -753,6 +756,7 @@ let compute_exp_alg bot join = ; e_sizeof = (fun nexp -> (bot, E_sizeof nexp)) ; e_constraint = (fun nc -> (bot, E_constraint nc)) ; e_exit = (fun (v1,e1) -> (v1, E_exit (e1))) + ; e_throw = (fun (v1,e1) -> (v1, E_throw (e1))) ; e_return = (fun (v1,e1) -> (v1, E_return e1)) ; e_assert = (fun ((v1,e1),(v2,e2)) -> (join v1 v2, E_assert(e1,e2)) ) ; e_internal_cast = (fun (a,(v1,e1)) -> (v1, E_internal_cast (a,e1))) diff --git a/src/rewriter.mli b/src/rewriter.mli index 9fa17a53..cd293ca5 100644 --- a/src/rewriter.mli +++ b/src/rewriter.mli @@ -133,6 +133,7 @@ type ('a,'exp,'exp_aux,'lexp,'lexp_aux,'fexp,'fexp_aux,'fexps,'fexps_aux, ; e_sizeof : nexp -> 'exp_aux ; e_constraint : n_constraint -> 'exp_aux ; e_exit : 'exp -> 'exp_aux + ; e_throw : 'exp -> 'exp_aux ; e_return : 'exp -> 'exp_aux ; e_assert : 'exp * 'exp -> 'exp_aux ; e_internal_cast : 'a annot * 'exp -> 'exp_aux diff --git a/src/rewrites.ml b/src/rewrites.ml index 8963d189..100b9eb7 100644 --- a/src/rewrites.ml +++ b/src/rewrites.ml @@ -364,6 +364,7 @@ let rewrite_sizeof (Defs defs) = ; e_sizeof = (fun nexp -> (E_sizeof nexp, E_sizeof nexp)) ; e_constraint = (fun nc -> (E_constraint nc, E_constraint nc)) ; e_exit = (fun (e1,e1') -> (E_exit (e1), E_exit (e1'))) + ; e_throw = (fun (e1,e1') -> (E_throw (e1), E_throw (e1'))) ; e_return = (fun (e1,e1') -> (E_return e1, E_return e1')) ; e_assert = (fun ((e1,e1'),(e2,e2')) -> (E_assert(e1,e2), E_assert(e1',e2')) ) ; e_internal_cast = (fun (a,(e1,e1')) -> (E_internal_cast (a,e1), E_internal_cast (a,e1'))) -- cgit v1.2.3