path: root/src/gen_lib/sail_values.lem

open import Pervasives_extra
open import Interp     (* only for converting between shallow- and deep-embedding values *)
open import Interp_ast (* only for converting between shallow- and deep-embedding values *)
open import Sail_impl_base


type ii = integer
type nn = natural

val pow : integer -> integer -> integer
let pow m n = m ** (natFromInteger n)

let rec replace bs ((n : integer),b') = match bs with
  | [] -> []
  | b :: bs ->
     if n = 0 then b' :: bs
              else b :: replace bs (n - 1,b')
  end


                     
(*** Bits *)
type bitU = O | I | Undef

let showBitU = function
  | O -> "O"
  | I -> "I"
  | Undef -> "Undef"
end

instance (Show bitU)
  let show = showBitU
end


let to_bool = function
  | O -> false
  | I  -> true
  | Undef -> failwith "to_bool applied to Undef"
  end

let bit_lifted_of_bitU = function
  | O -> Bitl_zero
  | I -> Bitl_one
  | Undef -> Bitl_undef
  end

let bitU_of_bit = function
  | Bitc_zero -> O
  | Bitc_one  -> I
  end

let bit_of_bitU = function
  | O -> Bitc_zero
  | I -> Bitc_one
  | Undef -> failwith "bit_of_bitU: Undef"
  end

let bitU_of_bit_lifted = function
  | Bitl_zero -> O
  | Bitl_one  -> I
  | Bitl_undef -> Undef
  | Bitl_unknown -> failwith "bitU_of_bit_lifted Bitl_unknown"
  end

let bitwise_not_bit = function
  | I -> O
  | O -> I
  | Undef -> Undef
  end

let inline (~) = bitwise_not_bit

val is_one : integer -> bitU
let is_one i =
  if i = 1 then I else O

let bool_to_bit b = if b then I else O

let bitwise_binop_bit op = function
  | (Undef,_) -> Undef (*Do we want to do this or to respect | of I and & of B0 rules?*)
  | (_,Undef) -> Undef (*Do we want to do this or to respect | of I and & of B0 rules?*)
  | (x,y) -> bool_to_bit (op (to_bool x) (to_bool y))
  end

val bitwise_and_bit : bitU * bitU -> bitU
let bitwise_and_bit = bitwise_binop_bit (&&)

val bitwise_or_bit : bitU * bitU -> bitU
let bitwise_or_bit = bitwise_binop_bit (||)

val bitwise_xor_bit : bitU * bitU -> bitU
let bitwise_xor_bit = bitwise_binop_bit xor

val (&.) : bitU -> bitU -> bitU
let inline (&.) x y = bitwise_and_bit (x,y)

val (|.) : bitU -> bitU -> bitU
let inline (|.) x y = bitwise_or_bit (x,y)

val (+.) : bitU -> bitU -> bitU
let inline (+.) x y = bitwise_xor_bit (x,y)



(*** Vectors *)

(* element list * start * has increasing direction *)
type vector 'a = Vector of list 'a * integer * bool

let showVector (Vector elems start inc) =
  "Vector " ^ show elems ^ " " ^ show start ^ " " ^ show inc

let get_dir (Vector _ _ ord) = ord
let get_start (Vector _ s _) = s
let get_elems (Vector elems _ _) = elems
let length (Vector bs _ _) = integerFromNat (length bs)

instance forall 'a. Show 'a => (Show (vector 'a))
  let show = showVector
end

let dir is_inc = if is_inc then D_increasing else D_decreasing
let bool_of_dir = function
  | D_increasing -> true
  | D_decreasing -> false
  end

(*** Vector operations *)

val set_vector_start : forall 'a. integer -> vector 'a -> vector 'a
let set_vector_start new_start (Vector bs _ is_inc) =
  Vector bs new_start is_inc

let copy v =
  set_vector_start (if (get_dir v) then 0 else (length v - 1)) v

let set_vector_start_to_length v =
  set_vector_start (length v - 1) v

let vector_concat (Vector bs start is_inc) (Vector bs' _ _) =
  Vector (bs ++ bs') start is_inc

let inline (^^) = vector_concat

val sublist : forall 'a. list 'a -> (nat * nat) -> list 'a
let sublist xs (i,j) =
  let (toJ,_suffix) = List.splitAt (j+1) xs in
  let (_prefix,fromItoJ) = List.splitAt i toJ in
  fromItoJ

val update_sublist : forall 'a. list 'a -> (nat * nat) -> list 'a -> list 'a
let update_sublist xs (i,j) xs' =
  let (toJ,suffix) = List.splitAt (j+1) xs in
  let (prefix,_fromItoJ) = List.splitAt i toJ in
  prefix ++ xs' ++ suffix

val slice : forall 'a. vector 'a -> integer -> integer -> vector 'a
let slice (Vector bs start is_inc) i j =
  let iN = natFromInteger i in
  let jN = natFromInteger j in
  let startN = natFromInteger start in
  let subvector_bits =
    sublist bs (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) in
  Vector subvector_bits i is_inc

(* this is for the vector slicing introduced in vector-concat patterns: i and j
index into the "raw data", the list of bits. Therefore getting the bit list is
easy, but the start index has to be transformed to match the old vector start
and the direction. *)
val slice_raw : forall 'a. vector 'a -> integer -> integer -> vector 'a
let slice_raw (Vector bs start is_inc) i j =
  let iN = natFromInteger i in
  let jN = natFromInteger j in
  let bits = sublist bs (iN,jN) in
  let len = integerFromNat (List.length bits) in
  Vector bits (if is_inc then 0 else len - 1) is_inc


val update_aux : forall 'a. vector 'a -> integer -> integer -> list 'a -> vector 'a
let update_aux (Vector bs start is_inc) i j bs' =
  let iN = natFromInteger i in
  let jN = natFromInteger j in
  let startN = natFromInteger start in
  let bits =
    (update_sublist bs)
      (if is_inc then (iN-startN,jN-startN) else (startN-iN,startN-jN)) bs' in
  Vector bits start is_inc

val update : forall 'a. vector 'a -> integer -> integer -> vector 'a -> vector 'a
let update v i j (Vector bs' _ _) =
  update_aux v i j bs'

val access : forall 'a. vector 'a -> integer -> 'a
let access (Vector bs start is_inc) n =
  if is_inc then List_extra.nth bs (natFromInteger (n - start))
  else List_extra.nth bs (natFromInteger (start - n))

val update_pos : forall 'a. vector 'a -> integer -> 'a -> vector 'a
let update_pos v n b =
  update_aux v n n [b]


(*** Bit vector operations *)

let extract_only_bit (Vector elems _ _) = match elems with
  | [] -> failwith "extract_single_bit called for empty vector"
  | [e] -> e
  | _ -> failwith "extract_single_bit called for vector with more bits"
end

let pp_bitu_vector (Vector elems start inc) =
  let elems_pp = List.foldl (fun acc elem -> acc ^ showBitU elem) "" elems in
  "Vector [" ^ elems_pp ^ "] " ^ show start ^ " " ^ show inc


let most_significant = function
  | (Vector (b :: _) _ _) -> b
  | _ -> failwith "most_significant applied to empty vector"
  end

let bitwise_not_bitlist = List.map bitwise_not_bit

let bitwise_not (Vector bs start is_inc) =
  Vector (bitwise_not_bitlist bs) start is_inc

let bitwise_binop op (Vector bsl start is_inc, Vector bsr _ _) =
  let revbs = foldl (fun acc pair -> bitwise_binop_bit op pair :: acc) [] (zip bsl bsr) in
  Vector (reverse revbs) start is_inc

let bitwise_and = bitwise_binop (&&)
let bitwise_or = bitwise_binop (||)
let bitwise_xor = bitwise_binop xor

let unsigned (Vector bs _ _) : integer =
  let (sum,_) =
    List.foldr
      (fun b (acc,exp) ->
        match b with
        | I -> (acc + integerPow 2 exp,exp + 1)
        | O -> (acc, exp + 1)
        | Undef -> failwith "unsigned: vector has undefined bits"
        end)
      (0,0) bs in
  sum

let unsigned_big = unsigned

let signed v : integer =
  match most_significant v with
  | I -> 0 - (1 + (unsigned (bitwise_not v)))
  | O -> unsigned v
  | Undef -> failwith "signed applied to vector with undefined bits"
  end

let hardware_mod (a: integer) (b:integer) : integer = 
 if a < 0 && b < 0
 then (abs a) mod (abs b)
 else if (a < 0 && b >= 0) 
 then (a mod b) - b
 else a mod b

let hardware_quot (a:integer) (b:integer) : integer = 
  if a < 0 && b < 0
  then (abs a) / (abs b)
  else if (a < 0 && b > 0) 
  then (a/b) + 1
  else a/b


let signed_big = signed

let to_num sign = if sign then signed else unsigned

let max_64u = (integerPow 2 64) - 1
let max_64  = (integerPow 2 63) - 1
let min_64  = 0 - (integerPow 2 63)
let max_32u = (4294967295 : integer)
let max_32  = (2147483647 : integer)
let min_32  = (0 - 2147483648 : integer)
let max_8   = (127 : integer)
let min_8   = (0 - 128 : integer)
let max_5   = (31 : integer)
let min_5   = (0 - 32 : integer)

let get_max_representable_in sign (n : integer) : integer =
  if (n = 64) then match sign with | true -> max_64 | false -> max_64u end
  else if (n=32) then match sign with | true -> max_32 | false -> max_32u end
  else if (n=8) then max_8
  else if (n=5) then max_5
  else match sign with | true -> integerPow 2 ((natFromInteger n) -1)
                       | false -> integerPow 2 (natFromInteger n)
       end

let get_min_representable_in _ (n : integer) : integer =
  if n = 64 then min_64
  else if n = 32 then min_32
  else if n = 8 then min_8
  else if n = 5 then min_5
  else 0 - (integerPow 2 (natFromInteger n))

val to_bin_aux : natural -> list bitU
let rec to_bin_aux x =
  if x = 0 then []
  else (if x mod 2 = 1 then I else O) :: to_bin_aux (x / 2)
let to_bin n = List.reverse (to_bin_aux n)

val pad_zero : list bitU -> integer -> list bitU
let rec pad_zero bits n =
  if n = 0 then bits else pad_zero (O :: bits) (n -1)


let rec add_one_bit_ignore_overflow_aux bits = match bits with
  | [] -> []
  | O :: bits -> I :: bits
  | I :: bits -> O :: add_one_bit_ignore_overflow_aux bits
  | Undef :: _ -> failwith "add_one_bit_ignore_overflow: undefined bit"
end

let add_one_bit_ignore_overflow bits =
  List.reverse (add_one_bit_ignore_overflow_aux (List.reverse bits))
  

let to_vec is_inc ((len : integer),(n : integer)) =
  let start = if is_inc then 0 else len - 1 in
  let bits = to_bin (naturalFromInteger (abs n)) in
  let len_bits = integerFromNat (List.length bits) in
  let longer = len - len_bits in
  let bits' =
    if longer < 0 then drop (natFromInteger (abs (longer))) bits
    else pad_zero bits longer in
  if n > (0 : integer)
  then Vector bits' start is_inc
  else Vector (add_one_bit_ignore_overflow (bitwise_not_bitlist bits'))
              start is_inc

let to_vec_big = to_vec

let to_vec_inc = to_vec true
let to_vec_dec = to_vec false

let to_vec_undef is_inc (len : integer) =
  Vector (replicate (natFromInteger len) Undef) (if is_inc then 0 else len-1) is_inc

let to_vec_inc_undef = to_vec_undef true
let to_vec_dec_undef = to_vec_undef false

let exts (len, vec) = to_vec (get_dir vec) (len,signed vec)
let extz (len, vec) = to_vec (get_dir vec) (len,unsigned vec)

let exts_big (len, vec) = to_vec_big (get_dir vec) (len, signed_big vec)
let extz_big (len, vec) = to_vec_big (get_dir vec) (len, unsigned_big vec)

let add = integerAdd
let add_signed = integerAdd
let minus = integerMinus
let multiply = integerMult
let modulo = hardware_mod
let quot = hardware_quot
let power = integerPow

let arith_op_vec op sign (size : integer) (Vector _ _ is_inc as l) r =
  let (l',r') = (to_num sign l, to_num sign r) in
  let n = op l' r' in
  to_vec is_inc (size * (length l),n)


(* add_vec
 * add_vec_signed
 * minus_vec
 * multiply_vec
 * multiply_vec_signed
 *)
let add_VVV = arith_op_vec integerAdd false 1
let addS_VVV = arith_op_vec integerAdd true 1
let minus_VVV = arith_op_vec integerMinus false 1
let mult_VVV = arith_op_vec integerMult false 2
let multS_VVV = arith_op_vec integerMult true 2

let arith_op_vec_range op sign size (Vector _ _ is_inc as l) r =
  arith_op_vec op sign size l (to_vec is_inc (length l,r))

(* add_vec_range
 * add_vec_range_signed
 * minus_vec_range
 * mult_vec_range
 * mult_vec_range_signed
 *)
let add_VIV = arith_op_vec_range integerAdd false 1
let addS_VIV = arith_op_vec_range integerAdd true 1
let minus_VIV = arith_op_vec_range integerMinus false 1
let mult_VIV = arith_op_vec_range integerMult false 2
let multS_VIV = arith_op_vec_range integerMult true 2

let arith_op_range_vec op sign size l (Vector _ _ is_inc as r) =
  arith_op_vec op sign size (to_vec is_inc (length r, l)) r

(* add_range_vec
 * add_range_vec_signed
 * minus_range_vec
 * mult_range_vec
 * mult_range_vec_signed
 *)
let add_IVV = arith_op_range_vec integerAdd false 1
let addS_IVV = arith_op_range_vec integerAdd true 1
let minus_IVV = arith_op_range_vec integerMinus false 1
let mult_IVV = arith_op_range_vec integerMult false 2
let multS_IVV = arith_op_range_vec integerMult true 2

let arith_op_range_vec_range op sign l r = op l (to_num sign r)

(* add_range_vec_range
 * add_range_vec_range_signed
 * minus_range_vec_range
 *)
let add_IVI = arith_op_range_vec_range integerAdd false
let addS_IVI = arith_op_range_vec_range integerAdd true
let minus_IVI = arith_op_range_vec_range integerMinus false

let arith_op_vec_range_range op sign l r = op (to_num sign l) r

(* add_vec_range_range
 * add_vec_range_range_signed
 * minus_vec_range_range
 *)
let add_VII = arith_op_vec_range_range integerAdd false
let addS_VII = arith_op_vec_range_range integerAdd true
let minus_VII = arith_op_vec_range_range integerMinus false



let arith_op_vec_vec_range op sign l r =
  let (l',r') = (to_num sign l,to_num sign r) in
  op l' r'

(* add_vec_vec_range
 * add_vec_vec_range_signed
 *)
let add_VVI = arith_op_vec_vec_range integerAdd false
let addS_VVI = arith_op_vec_vec_range integerAdd true

let arith_op_vec_bit op sign (size : integer) (Vector _ _ is_inc as l)r =
  let l' = to_num sign l in
  let n = op l' (match r with | I -> (1 : integer) | _ -> 0 end) in
  to_vec is_inc (length l * size,n)

(* add_vec_bit
 * add_vec_bit_signed
 * minus_vec_bit_signed
 *)
let add_VBV = arith_op_vec_bit integerAdd false 1
let addS_VBV = arith_op_vec_bit integerAdd true 1
let minus_VBV = arith_op_vec_bit integerMinus true 1

let rec arith_op_overflow_vec (op : integer -> integer -> integer) sign size (Vector _ _ is_inc as l) r =
  let len = length l in
  let act_size = len * size in
  let (l_sign,r_sign) = (to_num sign l,to_num sign r) in
  let (l_unsign,r_unsign) = (to_num false l,to_num false r) in
  let n = op l_sign r_sign in
  let n_unsign = op l_unsign r_unsign in
  let correct_size_num = to_vec is_inc (act_size,n) in
  let one_more_size_u = to_vec is_inc (act_size + 1,n_unsign) in
  let overflow =
    if n <= get_max_representable_in sign len &&
         n >= get_min_representable_in sign len
    then O else I in
  let c_out = most_significant one_more_size_u in
  (correct_size_num,overflow,c_out)

(* add_overflow_vec
 * add_overflow_vec_signed
 * minus_overflow_vec
 * minus_overflow_vec_signed
 * mult_overflow_vec
 * mult_overflow_vec_signed
 *)
let addO_VVV = arith_op_overflow_vec integerAdd false 1
let addSO_VVV = arith_op_overflow_vec integerAdd true 1
let minusO_VVV = arith_op_overflow_vec integerMinus false 1
let minusSO_VVV = arith_op_overflow_vec integerMinus true 1
let multO_VVV = arith_op_overflow_vec integerMult false 2
let multSO_VVV = arith_op_overflow_vec integerMult true 2

let rec arith_op_overflow_vec_bit (op : integer -> integer -> integer) sign (size : integer)
                                  (Vector _ _ is_inc as l) r_bit =
  let act_size = length l * size in
  let l' = to_num sign l in
  let l_u = to_num false l in
  let (n,nu,changed) = match r_bit with
    | I -> (op l' 1, op l_u 1, true)
    | O -> (l',l_u,false)
    | _ -> failwith "arith_op_overflow_vec_bit applied to undefined bit"
    end in
(*    | _ -> assert false *)
  let correct_size_num = to_vec is_inc (act_size,n) in
  let one_larger = to_vec is_inc (act_size + 1,nu) in
  let overflow =
    if changed
    then
      if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size
      then O else I
    else O in
  (correct_size_num,overflow,most_significant one_larger)

(* add_overflow_vec_bit_signed
 * minus_overflow_vec_bit
 * minus_overflow_vec_bit_signed
 *)
let addSO_VBV = arith_op_overflow_vec_bit integerAdd true 1
let minusO_VBV = arith_op_overflow_vec_bit integerMinus false 1
let minusSO_VBV = arith_op_overflow_vec_bit integerMinus true 1

type shift = LL_shift | RR_shift | LLL_shift

let shift_op_vec op (Vector bs start is_inc,(n : integer)) =
  let n = natFromInteger n in
  match op with
  | LL_shift (*"<<"*) ->
     Vector (sublist bs (n,List.length bs -1) ++ List.replicate n O) start is_inc
  | RR_shift (*">>"*) ->
     Vector (List.replicate n O ++ sublist bs (0,n-1)) start is_inc
  | LLL_shift (*"<<<"*) ->
     Vector (sublist bs (n,List.length bs - 1) ++ sublist bs (0,n-1)) start is_inc
  end

let bitwise_leftshift = shift_op_vec LL_shift (*"<<"*)
let bitwise_rightshift = shift_op_vec RR_shift (*">>"*)
let bitwise_rotate = shift_op_vec LLL_shift (*"<<<"*)

let rec arith_op_no0 (op : integer -> integer -> integer) l r =
  if r = 0
  then Nothing
  else Just (op l r)

let rec arith_op_vec_no0 (op : integer -> integer -> integer) sign size ((Vector _ start is_inc) as l) r =
  let act_size = length l * size in
  let (l',r') = (to_num sign l,to_num sign r) in
  let n = arith_op_no0 op l' r' in
  let (representable,n') =
    match n with
    | Just n' ->
      (n' <= get_max_representable_in sign act_size &&
         n' >= get_min_representable_in sign act_size, n')
    | _ -> (false,0)
    end in
  if representable
  then to_vec is_inc (act_size,n')
  else Vector (List.replicate (natFromInteger act_size) Undef) start is_inc

let mod_VVV = arith_op_vec_no0 hardware_mod false 1
let quot_VVV = arith_op_vec_no0 hardware_quot false 1
let quotS_VVV = arith_op_vec_no0 hardware_quot true 1

let arith_op_overflow_no0_vec op sign size ((Vector _ start is_inc) as l) r =
  let rep_size = length r * size in
  let act_size = length l * size in
  let (l',r') = (to_num sign l,to_num sign r) in
  let (l_u,r_u) = (to_num false l,to_num false r) in
  let n = arith_op_no0 op l' r' in
  let n_u = arith_op_no0 op l_u r_u in
  let (representable,n',n_u') =
    match (n, n_u) with
    | (Just n',Just n_u') ->
       ((n' <= get_max_representable_in sign rep_size &&
           n' >= (get_min_representable_in sign rep_size)), n', n_u')
    | _ -> (true,0,0)
    end in
  let (correct_size_num,one_more) =
    if representable then
      (to_vec is_inc (act_size,n'),to_vec is_inc (act_size + 1,n_u'))
    else
      (Vector (List.replicate (natFromInteger act_size) Undef) start is_inc,
       Vector (List.replicate (natFromInteger (act_size + 1)) Undef) start is_inc) in
  let overflow = if representable then O else I in
  (correct_size_num,overflow,most_significant one_more)

let quotO_VVV = arith_op_overflow_no0_vec hardware_quot false 1
let quotSO_VVV = arith_op_overflow_no0_vec hardware_quot true 1

let arith_op_vec_range_no0 op sign size (Vector _ _ is_inc as l) r =
  arith_op_vec_no0 op sign size l (to_vec is_inc (length l,r))

let mod_VIV = arith_op_vec_range_no0 hardware_mod false 1

val repeat : forall 'a. list 'a -> integer -> list 'a
let rec repeat xs n =
  if n = 0 then []
  else xs ++ repeat xs (n-1)

let compare_op op (l,r) = bool_to_bit (op l r)

let lt = compare_op (<)
let gt = compare_op (>)
let lteq = compare_op (<=)
let gteq = compare_op (>=)


let compare_op_vec op sign (l,r) =
  let (l',r') = (to_num sign l, to_num sign r) in
  compare_op op (l',r')

let lt_vec = compare_op_vec (<) true
let gt_vec = compare_op_vec (>) true
let lteq_vec = compare_op_vec (<=) true
let gteq_vec = compare_op_vec (>=) true

let lt_vec_signed = compare_op_vec (<) true
let gt_vec_signed = compare_op_vec (>) true
let lteq_vec_signed = compare_op_vec (<=) true
let gteq_vec_signed = compare_op_vec (>=) true
let lt_vec_unsigned = compare_op_vec (<) false
let gt_vec_unsigned = compare_op_vec (>) false
let lteq_vec_unsigned = compare_op_vec (<=) false
let gteq_vec_unsigned = compare_op_vec (>=) false

let compare_op_vec_range op sign (l,r) =
  compare_op op ((to_num sign l),r)

let lt_vec_range = compare_op_vec_range (<) true
let gt_vec_range = compare_op_vec_range (>) true
let lteq_vec_range = compare_op_vec_range (<=) true
let gteq_vec_range = compare_op_vec_range (>=) true

let compare_op_range_vec op sign (l,r) =
  compare_op op (l, (to_num sign r))

let lt_range_vec = compare_op_range_vec (<) true
let gt_range_vec = compare_op_range_vec (>) true
let lteq_range_vec = compare_op_range_vec (<=) true
let gteq_range_vec = compare_op_range_vec (>=) true

let eq (l,r) = bool_to_bit (l = r)
let eq_range (l,r) = bool_to_bit (l = r)
let eq_vec (l,r) = bool_to_bit (l = r)
let eq_bit (l,r) = bool_to_bit (l = r)
let eq_vec_range (l,r) = eq (to_num false l,r)
let eq_range_vec (l,r) = eq (l, to_num false r)
let eq_vec_vec (l,r) = eq (to_num true l, to_num true r)

let neq (l,r) = bitwise_not_bit (eq (l,r))
let neq_bit (l,r) = bitwise_not_bit (eq_bit (l,r))
let neq_range (l,r) = bitwise_not_bit (eq_range (l,r))
let neq_vec (l,r) = bitwise_not_bit (eq_vec_vec (l,r))
let neq_vec_range (l,r) = bitwise_not_bit (eq_vec_range (l,r))
let neq_range_vec (l,r) = bitwise_not_bit (eq_range_vec (l,r))


val make_indexed_vector : forall 'a. list (integer * 'a) -> 'a -> integer -> integer -> bool -> vector 'a
let make_indexed_vector entries default start length dir =
  let length = natFromInteger length in
  Vector (List.foldl replace (replicate length default) entries) start dir

(*
val make_bit_vector_undef : integer -> vector bitU
let make_bitvector_undef length =
  Vector (replicate (natFromInteger length) Undef) 0 true
 *)

(* let bitwise_not_range_bit n = bitwise_not (to_vec defaultDir n) *)

let mask (n,Vector bits start dir) =
  let current_size = List.length bits in
  Vector (drop (current_size - (natFromInteger n)) bits) (if dir then 0 else (n-1)) dir


val byte_chunks : forall 'a. nat -> list 'a -> list (list 'a)
let rec byte_chunks n list = match (n,list) with
  | (0,_) -> []
  | (n+1, a::b::c::d::e::f::g::h::rest) -> [a;b;c;d;e;f;g;h] :: byte_chunks n rest
  | _ -> failwith "byte_chunks not given enough bits"
end

val bitv_of_byte_lifteds : bool -> list Sail_impl_base.byte_lifted -> vector bitU
let bitv_of_byte_lifteds dir v =
  let bits = foldl (fun x (Byte_lifted y) -> x ++ (List.map bitU_of_bit_lifted y)) [] v in
  let len = integerFromNat (List.length bits) in
  Vector bits (if dir then 0 else len - 1) dir

val bitv_of_bytes : bool -> list Sail_impl_base.byte -> vector bitU
let bitv_of_bytes dir v =
  let bits = foldl (fun x (Byte y) -> x ++ (List.map bitU_of_bit y)) [] v in
  let len = integerFromNat (List.length bits) in
  Vector bits (if dir then 0 else len - 1) dir


val byte_lifteds_of_bitv : vector bitU -> list byte_lifted
let byte_lifteds_of_bitv (Vector bits length is_inc) =
  let bits = List.map bit_lifted_of_bitU bits in
  byte_lifteds_of_bit_lifteds bits

val bytes_of_bitv : vector bitU -> list byte
let bytes_of_bitv (Vector bits length is_inc) =
  let bits = List.map bit_of_bitU bits in
  bytes_of_bits bits

val bit_lifteds_of_bitUs : list bitU -> list bit_lifted
let bit_lifteds_of_bitUs bits = List.map bit_lifted_of_bitU bits

val bit_lifteds_of_bitv : vector bitU -> list bit_lifted
let bit_lifteds_of_bitv v = bit_lifteds_of_bitUs (get_elems v)


val address_lifted_of_bitv : vector bitU -> address_lifted
let address_lifted_of_bitv v =
  let byte_lifteds = byte_lifteds_of_bitv v in
  let maybe_address_integer =
    match (maybe_all (List.map byte_of_byte_lifted byte_lifteds)) with
    | Just bs -> Just (integer_of_byte_list bs)
    | _ -> Nothing
    end in
  Address_lifted byte_lifteds maybe_address_integer

val address_of_bitv : vector bitU -> address
let address_of_bitv v =
  let bytes = bytes_of_bitv v in
  address_of_byte_list bytes



(*** Registers *)

type register_field = string
type register_field_index = string * (integer * integer) (* name, start and end *)

type register =
  | Register of string * (* name *)
                integer * (* length *)
                integer * (* start index *)
                bool * (* is increasing *)
                  list register_field_index
  | UndefinedRegister of integer (* length *)
  | RegisterPair of register * register

let name_of_reg = function
  | Register name _ _ _ _ -> name
  | UndefinedRegister _ -> failwith "name_of_reg UndefinedRegister"
  | RegisterPair _ _ -> failwith "name_of_reg RegisterPair"
end

let size_of_reg = function
  | Register _ size _ _ _ -> size
  | UndefinedRegister size -> size
  | RegisterPair _ _ -> failwith "size_of_reg RegisterPair"
end
                              
let start_of_reg = function
  | Register _ _ start _ _ -> start
  | UndefinedRegister _ -> failwith "start_of_reg UndefinedRegister"
  | RegisterPair _ _ -> failwith "start_of_reg RegisterPair"
end

let is_inc_of_reg = function
  | Register _ _ _ is_inc _ -> is_inc
  | UndefinedRegister _ -> failwith "is_inc_of_reg UndefinedRegister"
  | RegisterPair _ _ -> failwith "in_inc_of_reg RegisterPair"
end

let dir_of_reg = function
  | Register _ _ _ is_inc _ -> dir is_inc
  | UndefinedRegister _ -> failwith "dir_of_reg UndefinedRegister"
  | RegisterPair _ _ -> failwith "dir_of_reg RegisterPair"
end

let size_of_reg_nat reg = natFromInteger (size_of_reg reg)
let start_of_reg_nat reg = natFromInteger (start_of_reg reg)

val register_field_indices_aux : register -> register_field -> maybe (integer * integer)
let rec register_field_indices_aux register rfield =
  match register with
  | Register _ _ _ _ rfields -> List.lookup rfield rfields
  | RegisterPair r1 r2 ->
      let m_indices = register_field_indices_aux r1 rfield in
      if isJust m_indices then m_indices else register_field_indices_aux r2 rfield
  | UndefinedRegister -> Nothing
  end

val register_field_indices : register -> register_field -> integer * integer
let register_field_indices register rfield =
  match register_field_indices_aux register rfield with
  | Just indices -> indices
  | Nothing -> failwith "Invalid register/register-field combination"
  end

let register_field_indices_nat reg regfield=
  let (i,j) = register_field_indices reg regfield in
  (natFromInteger i,natFromInteger j)

let rec extern_reg_value reg_name v = 
  let (internal_start, external_start, direction) =
    match reg_name with 
     | Reg _ start size dir ->
        (start, (if dir = D_increasing then start else (start - (size +1))), dir)
     | Reg_slice _ reg_start dir (slice_start, slice_end) ->
        ((if dir = D_increasing then slice_start else (reg_start - slice_start)),
         slice_start, dir)
     | Reg_field _ reg_start dir _ (slice_start, slice_end) ->
        ((if dir = D_increasing then slice_start else (reg_start - slice_start)),
         slice_start, dir)
     | Reg_f_slice _ reg_start dir _ _ (slice_start, slice_end) ->
        ((if dir = D_increasing then slice_start else (reg_start - slice_start)),
         slice_start, dir) 
     end in
  let bits = bit_lifteds_of_bitv v in
  <| rv_bits           = bits; 
     rv_dir            = direction;
     rv_start          = external_start;
     rv_start_internal = internal_start |>

val intern_reg_value : register_value -> vector bitU
let intern_reg_value v =
  Vector (List.map bitU_of_bit_lifted v.rv_bits)
         (integerFromNat v.rv_start_internal)
         (v.rv_dir = D_increasing)


let extern_slice (d:direction) (start:nat) ((i,j):(nat*nat)) =
  match d with
  (*This is the case the thread/concurrecny model expects, so no change needed*)
  | D_increasing -> (i,j)
  | D_decreasing -> let slice_i = start - i in 
                    let slice_j = (i - j) + slice_i in
                    (slice_i,slice_j)
  end 

let extern_reg_whole reg =
  Reg (name_of_reg reg) (start_of_reg_nat reg) (size_of_reg_nat reg) (dir_of_reg reg)
      
let extern_reg_slice reg (i,j) =
  let start = start_of_reg_nat reg in
  let dir = dir_of_reg reg in
  Reg_slice (name_of_reg reg) start dir (extern_slice dir start (i,j))

let extern_reg_field_whole reg rfield = 
  let (m,n) = register_field_indices_nat reg rfield in
  let start = start_of_reg_nat reg in
  let dir = dir_of_reg reg in
  Reg_field (name_of_reg reg) start dir rfield (extern_slice dir start (m,n))
            
let extern_reg_field_slice reg rfield (i,j) = 
  let (m,n) = register_field_indices_nat reg rfield in
  let start = start_of_reg_nat reg in
  let dir = dir_of_reg reg in
  Reg_f_slice (name_of_reg reg) start dir rfield
              (extern_slice dir start (m,n))
              (extern_slice dir start (i,j))

let extern_mem_value endian v =
  let bytes = byte_lifteds_of_bitv v in 
  if endian = E_big_endian then bytes else List.reverse bytes

let intern_mem_value endian direction bytes = 
  let v = if endian = E_big_endian then bytes else List.reverse bytes in
  bitv_of_byte_lifteds direction v



                       

val foreach_inc :  forall 'vars. (integer * integer * integer) -> 'vars ->
                   (integer -> 'vars -> 'vars) -> 'vars
let rec foreach_inc (i,stop,by) vars body =
  if i <= stop
  then let vars = body i vars in
       foreach_inc (i + by,stop,by) vars body
  else vars

val foreach_dec : forall 'vars. (integer * integer * integer) -> 'vars ->
                  (integer -> 'vars -> 'vars) -> 'vars
let rec foreach_dec (i,stop,by) vars body =
  if i >= stop
  then let vars = body i vars in
       foreach_dec (i - by,stop,by) vars body
  else vars

let assert' b msg_opt =
  let msg = match msg_opt with
  | Just msg -> msg
  | Nothing  -> "unspecified error"
  end in
  if to_bool b then () else failwith msg



                                     
(* convert numbers unsafely to naturals *)

class (ToNatural 'a) val toNatural : 'a -> natural end
instance (ToNatural integer) let toNatural = naturalFromInteger end
instance (ToNatural int)     let toNatural = naturalFromInt     end
instance (ToNatural nat)     let toNatural = naturalFromNat     end
instance (ToNatural natural) let toNatural = id                 end

let toNaturalFiveTup (n1,n2,n3,n4,n5) =
  (toNatural n1,
   toNatural n2,
   toNatural n3,
   toNatural n4,
   toNatural n5)



(* convert to/from interpreter values *)

class (ToFromInterpValue 'a)
  val toInterpValue : 'a -> Interp.value
  val fromInterpValue : Interp.value -> 'a
end

let toInterValueBool = function
  | true -> Interp.V_lit (L_aux (L_one) Unknown)
  | false -> Interp.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
  | v -> failwith ("fromInterpValue bool: unexpected value. " ^
                     Interp.debug_print_value v)
end
instance (ToFromInterpValue bool)
  let toInterpValue = toInterValueBool
  let fromInterpValue = fromInterpValueBool
end


let toInterpValueUnit () = Interp.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
  | v -> failwith ("fromInterpValue unit: unexpected value. " ^
                     Interp.debug_print_value v)
end
instance (ToFromInterpValue unit)
  let toInterpValue = toInterpValueUnit
  let fromInterpValue = fromInterpValueUnit
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
  | v -> failwith ("fromInterpValue integer: unexpected value. " ^
                     Interp.debug_print_value v)
end
instance (ToFromInterpValue integer)
  let toInterpValue = toInterpValueInteger
  let fromInterpValue = fromInterpValueInteger
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
  | v -> failwith ("fromInterpValue integer: unexpected value. " ^
                     Interp.debug_print_value v)
end
instance (ToFromInterpValue string)
  let toInterpValue = toInterpValueString
  let fromInterpValue = fromInterpValueString
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)
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
  | v -> failwith ("fromInterpValue bitU: unexpected value. " ^
                     Interp.debug_print_value v)
end
instance (ToFromInterpValue bitU)
  let toInterpValue = toInterpValueBitU
  let fromInterpValue = fromInterpValueBitU
end


let tuple2ToInterpValue (a,b) =
  V_tuple [toInterpValue a;toInterpValue b]
let rec tuple2FromInterpValue v = match v with
  | V_tuple [a;b] -> (fromInterpValue a,fromInterpValue b)
  | V_tuple [v] -> tuple2FromInterpValue v
  | v -> failwith ("fromInterpValue a*b: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b. ToFromInterpValue 'a, ToFromInterpValue 'b => (ToFromInterpValue ('a * 'b))
  let toInterpValue = tuple2ToInterpValue
  let fromInterpValue = tuple2FromInterpValue
end


let tuple3ToInterpValue (a,b,c) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c]
let rec tuple3FromInterpValue v = match v with
  | V_tuple [a;b;c] -> (fromInterpValue a,fromInterpValue b,fromInterpValue c)
  | V_tuple [v] -> tuple3FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c. ToFromInterpValue 'a, ToFromInterpValue 'b, ToFromInterpValue 'c =>
    (ToFromInterpValue ('a * 'b * 'c))
  let toInterpValue = tuple3ToInterpValue
  let fromInterpValue = tuple3FromInterpValue
end


let tuple4ToInterpValue (a,b,c,d) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d]
let rec tuple4FromInterpValue v = match v with
  | V_tuple [a;b;c;d] -> (fromInterpValue a,fromInterpValue b,
                          fromInterpValue c,fromInterpValue d)
  | V_tuple [v] -> tuple4FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd. ToFromInterpValue 'a, ToFromInterpValue 'b,
                             ToFromInterpValue 'c, ToFromInterpValue 'd =>
    (ToFromInterpValue ('a * 'b * 'c * 'd))
  let toInterpValue = tuple4ToInterpValue
  let fromInterpValue = tuple4FromInterpValue
end


let tuple5ToInterpValue (a,b,c,d,e) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;toInterpValue e]
let rec tuple5FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e)
  | V_tuple [v] -> tuple5FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e))
  let toInterpValue = tuple5ToInterpValue
  let fromInterpValue = tuple5FromInterpValue
end


let tuple6ToInterpValue (a,b,c,d,e,f) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f]
let rec tuple6FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f)
  | V_tuple [v] -> tuple6FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f))
  let toInterpValue = tuple6ToInterpValue
  let fromInterpValue = tuple6FromInterpValue
end


let tuple7ToInterpValue (a,b,c,d,e,f,g) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f;toInterpValue g]
let rec tuple7FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f;g] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f,
      fromInterpValue g)
  | V_tuple [v] -> tuple7FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f*g: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f 'g.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f,
    ToFromInterpValue 'g =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f * 'g))
  let toInterpValue = tuple7ToInterpValue
  let fromInterpValue = tuple7FromInterpValue
end


let tuple8ToInterpValue (a,b,c,d,e,f,g,h) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f;toInterpValue g;toInterpValue h]
let rec tuple8FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f;g;h] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f,
      fromInterpValue g,fromInterpValue h)
  | V_tuple [v] -> tuple8FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f*g*h: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f 'g 'h.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f,
    ToFromInterpValue 'g, ToFromInterpValue 'h =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h))
  let toInterpValue = tuple8ToInterpValue
  let fromInterpValue = tuple8FromInterpValue
end


let tuple9ToInterpValue (a,b,c,d,e,f,g,h,i) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f;toInterpValue g;toInterpValue h;
           toInterpValue i]
let rec tuple9FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f;g;h;i] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f,
      fromInterpValue g,fromInterpValue h,fromInterpValue i)
  | V_tuple [v] -> tuple9FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f*g*h*i: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f 'g 'h 'i.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f,
    ToFromInterpValue 'g, ToFromInterpValue 'h,
    ToFromInterpValue 'i =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i))
  let toInterpValue = tuple9ToInterpValue
  let fromInterpValue = tuple9FromInterpValue
end


let tuple10ToInterpValue (a,b,c,d,e,f,g,h,i,j) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f;toInterpValue g;toInterpValue h;
           toInterpValue i;toInterpValue j;]
let rec tuple10FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f;g;h;i;j] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f,
      fromInterpValue g,fromInterpValue h,fromInterpValue i,
      fromInterpValue j)
  | V_tuple [v] -> tuple10FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f*g*h*i*j: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f,
    ToFromInterpValue 'g, ToFromInterpValue 'h,
    ToFromInterpValue 'i, ToFromInterpValue 'j =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j))
  let toInterpValue = tuple10ToInterpValue
  let fromInterpValue = tuple10FromInterpValue
end


let tuple11ToInterpValue (a,b,c,d,e,f,g,h,i,j,k) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f;toInterpValue g;toInterpValue h;
           toInterpValue i;toInterpValue j;toInterpValue k;]
let rec tuple11FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f;g;h;i;j;k] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f,
      fromInterpValue g,fromInterpValue h,fromInterpValue i,
      fromInterpValue j,fromInterpValue k)
  | V_tuple [v] -> tuple11FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f*g*h*i*j*k: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f,
    ToFromInterpValue 'g, ToFromInterpValue 'h,
    ToFromInterpValue 'i, ToFromInterpValue 'j,
    ToFromInterpValue 'k =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k))
  let toInterpValue = tuple11ToInterpValue
  let fromInterpValue = tuple11FromInterpValue
end


let tuple12ToInterpValue (a,b,c,d,e,f,g,h,i,j,k,l) =
  V_tuple [toInterpValue a;toInterpValue b;toInterpValue c;toInterpValue d;
           toInterpValue e;toInterpValue f;toInterpValue g;toInterpValue h;
           toInterpValue i;toInterpValue j;toInterpValue k;toInterpValue l;]
let rec tuple12FromInterpValue v = match v with
  | V_tuple [a;b;c;d;e;f;g;h;i;j;k;l] ->
     (fromInterpValue a,fromInterpValue b,fromInterpValue c,
      fromInterpValue d,fromInterpValue e,fromInterpValue f,
      fromInterpValue g,fromInterpValue h,fromInterpValue i,
      fromInterpValue j,fromInterpValue k,fromInterpValue l)
  | V_tuple [v] -> tuple12FromInterpValue v
  | v -> failwith ("fromInterpValue a*b*c*d*e*f*g*h*i*j*k*l: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l.
    ToFromInterpValue 'a, ToFromInterpValue 'b,
    ToFromInterpValue 'c, ToFromInterpValue 'd,
    ToFromInterpValue 'e, ToFromInterpValue 'f,
    ToFromInterpValue 'g, ToFromInterpValue 'h,
    ToFromInterpValue 'i, ToFromInterpValue 'j,
    ToFromInterpValue 'k, ToFromInterpValue 'l =>
    (ToFromInterpValue ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i * 'j * 'k * 'l))
  let toInterpValue = tuple12ToInterpValue
  let fromInterpValue = tuple12FromInterpValue
end


let listToInterpValue l = V_list (List.map toInterpValue l)
let rec listFromInterpValue v = match v with
  | V_list l -> List.map fromInterpValue l
  | V_tuple [v] -> listFromInterpValue v
  | v -> failwith ("fromInterpValue list 'a: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a. ToFromInterpValue 'a => (ToFromInterpValue (list 'a))
  let toInterpValue = listToInterpValue
  let fromInterpValue = listFromInterpValue
end


let vectorToInterpValue (Vector vs start direction) =
  V_vector (natFromInteger start) (if direction then IInc else IDec) (List.map toInterpValue vs)
let rec vectorFromInterpValue v = match v with
  | V_vector start direction vs ->
     Vector (List.map fromInterpValue vs) (integerFromNat start)
            (match direction with | IInc -> true | IDec -> false end)
  | V_vector_sparse start length direction valuemap defaultval ->
     make_indexed_vector
       (List.map (fun (i,v) -> (integerFromNat i,fromInterpValue v)) valuemap)
       (fromInterpValue defaultval)
       (integerFromNat start) (integerFromNat length)
       (match direction with | IInc -> true | IDec -> false end)
  | V_tuple [v] -> vectorFromInterpValue v
  | v -> failwith ("fromInterpValue vector 'a: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance forall 'a. ToFromInterpValue 'a => (ToFromInterpValue (vector 'a))
  let toInterpValue = vectorToInterpValue
  let fromInterpValue = vectorFromInterpValue
end

(* Here the type information is not accurate: instead of T_id "option" it should
   be T_app (T_id "option") (...), but temporarily we'll do it like this. The
   same thing has to be fixed in pretty_print.ml when we're generating the
   type-class instances. *)
let maybeToInterpValue = function
  | Nothing -> V_ctor (Id_aux (Id "None") Unknown) (T_id "option") C_Union (V_lit (L_aux L_unit Unknown))
  | Just a  -> V_ctor (Id_aux (Id "Some") Unknown) (T_id "option") C_Union (toInterpValue a)
  end
let rec maybeFromInterpValue v = match v with
  | V_ctor (Id_aux (Id "None") _) _ _ _ -> Nothing
  | V_ctor (Id_aux (Id "Some") _) _ _ v -> Just (fromInterpValue v)
  | V_tuple [v] -> maybeFromInterpValue v
  | v -> failwith ("fromInterpValue maybe 'a: unexpected value. " ^
                     Interp.debug_print_value v)
  end

instance forall 'a. ToFromInterpValue 'a => (ToFromInterpValue (maybe 'a))
  let toInterpValue = maybeToInterpValue
  let fromInterpValue = maybeFromInterpValue
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 ())
  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_tuple [v] -> read_kindFromInterpValue v
  | v -> failwith ("fromInterpValue read_kind: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance (ToFromInterpValue read_kind)
  let toInterpValue = read_kindToInterpValue
  let fromInterpValue = read_kindFromInterpValue
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 ())
  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_tuple [v] -> write_kindFromInterpValue v
  | v -> failwith ("fromInterpValue write_kind: unexpected value " ^
                     Interp.debug_print_value v)
  end
instance (ToFromInterpValue write_kind)
  let toInterpValue = write_kindToInterpValue
  let fromInterpValue = write_kindFromInterpValue
end


let barrier_kindToInterpValue = function
  | Barrier_Sync -> V_ctor (Id_aux (Id "Barrier_Sync") Unknown) (T_id "barrier_kind") (C_Enum 0) (toInterpValue ())
  | Barrier_LwSync -> V_ctor (Id_aux (Id "Barrier_LwSync") Unknown) (T_id "barrier_kind") (C_Enum 1) (toInterpValue ())
  | Barrier_Eieio -> V_ctor (Id_aux (Id "Barrier_Eieio") Unknown) (T_id "barrier_kind") (C_Enum 2) (toInterpValue ())
  | Barrier_Isync -> V_ctor (Id_aux (Id "Barrier_Isync") Unknown) (T_id "barrier_kind") (C_Enum 3) (toInterpValue ())
  | Barrier_DMB -> V_ctor (Id_aux (Id "Barrier_DMB") Unknown) (T_id "barrier_kind") (C_Enum 4) (toInterpValue ())
  | Barrier_DMB_ST -> V_ctor (Id_aux (Id "Barrier_DMB_ST") Unknown) (T_id "barrier_kind") (C_Enum 5) (toInterpValue ())
  | Barrier_DMB_LD -> V_ctor (Id_aux (Id "Barrier_DMB_LD") Unknown) (T_id "barrier_kind") (C_Enum 6) (toInterpValue ())
  | Barrier_DSB -> V_ctor (Id_aux (Id "Barrier_DSB") Unknown) (T_id "barrier_kind") (C_Enum 7) (toInterpValue ())
  | 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 ())
  end
let rec barrier_kindFromInterpValue v = match v with
  | V_ctor (Id_aux (Id "Barrier_Sync") _) _ _ v -> Barrier_Sync
  | V_ctor (Id_aux (Id "Barrier_LwSync") _) _ _ v -> Barrier_LwSync
  | V_ctor (Id_aux (Id "Barrier_Eieio") _) _ _ v -> Barrier_Eieio
  | V_ctor (Id_aux (Id "Barrier_Isync") _) _ _ v -> Barrier_Isync
  | V_ctor (Id_aux (Id "Barrier_DMB") _) _ _ v -> Barrier_DMB
  | V_ctor (Id_aux (Id "Barrier_DMB_ST") _) _ _ v -> Barrier_DMB_ST
  | V_ctor (Id_aux (Id "Barrier_DMB_LD") _) _ _ v -> Barrier_DMB_LD
  | V_ctor (Id_aux (Id "Barrier_DSB") _) _ _ v -> Barrier_DSB
  | 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_tuple [v] -> barrier_kindFromInterpValue v
  | v -> failwith ("fromInterpValue barrier_kind: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance (ToFromInterpValue barrier_kind)
  let toInterpValue = barrier_kindToInterpValue
  let fromInterpValue = barrier_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_cond_branch -> V_ctor (Id_aux (Id "IK_cond_branch") Unknown) (T_id "instruction_kind") C_Union (toInterpValue ())
  | 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_cond_branch") _) _ _ v -> IK_cond_branch
  | V_ctor (Id_aux (Id "IK_simple") _) _ _ v -> IK_simple
  | V_tuple [v] -> instruction_kindFromInterpValue v
  | v -> failwith ("fromInterpValue instruction_kind: unexpected value. " ^
                     Interp.debug_print_value v)
  end
instance (ToFromInterpValue instruction_kind)
  let toInterpValue = instruction_kindToInterpValue
  let fromInterpValue = instruction_kindFromInterpValue
end


type regfp =
  | RFull of (string)
  | RSlice of (string * integer * integer)
  | RSliceBit of (string * integer)
  | RField of (string * string)

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)
  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
  | v -> failwith ("fromInterpValue regfp: unexpected value. " ^ Interp.debug_print_value v)
  end

instance (ToFromInterpValue regfp)
  let toInterpValue = regfpToInterpValue
  let fromInterpValue = regfpFromInterpValue
end


let regfp_to_reg (reg_info : string -> maybe string -> (nat * nat * direction * (nat * nat))) = function
  | RFull name -> 
     let (start,length,direction,_) = reg_info name Nothing in
     Reg name start length direction
  | RSlice (name,i,j) ->
     let i = natFromInteger i in
     let j = natFromInteger j in
     let (start,length,direction,_) = reg_info name Nothing in
     let slice = extern_slice direction start (i,j) in
     Reg_slice name start direction slice
  | RSliceBit (name,i) ->
     let i = natFromInteger i in
     let (start,length,direction,_) = reg_info name Nothing in
     let slice = extern_slice direction start (i,i) in
     Reg_slice name start direction slice
  | RField (name,field_name) ->
     let (start,length,direction,span) = reg_info name (Just field_name) in
     let slice = extern_slice direction start span in
     Reg_field name start direction field_name slice
end


type niafp = 
  | NIAFP_successor
  | NIAFP_concrete_address of vector bitU
  | NIAFP_LR
  | NIAFP_CTR
  | NIAFP_register of regfp

(* only for MIPS *)
type diafp = 
  | DIAFP_none
  | DIAFP_concrete of vector bitU
  | DIAFP_reg of regfp

let niafp_to_nia reginfo = function
  | NIAFP_successor -> NIA_successor
  | NIAFP_concrete_address v -> NIA_concrete_address (address_of_bitv v)
  | NIAFP_LR -> NIA_LR
  | NIAFP_CTR -> NIA_CTR
  | NIAFP_register r -> NIA_register (regfp_to_reg reginfo r)
end

let diafp_to_dia reginfo = function
  | DIAFP_none -> DIA_none
  | DIAFP_concrete v -> DIA_concrete_address (address_of_bitv v)
  | DIAFP_reg r -> DIA_register (regfp_to_reg reginfo r)
end