Theory LLVM_Shallow

section ‹Shallow Embedding of LLVM Semantics›
theory LLVM_Shallow
imports Main  
  "Simple_Memory"
begin


  subsection ‹Shallow Embedding of Values›  

  text ‹We use a type class to characterize types that can be injected into the value type.
    We will instantiate this type class to obtain injections from types of shape 
    ‹T = T×T | _ word | _ ptr›
  
    Although, this type class can be instantiated by other types, those will not be accepted 
    by the code generator.
    
    We also define a class ‹llvm_repv›, which additionally contains ‹unit›. 
    This is required for void functions, and if-the-else statements that produce no result.
    
    Again, while this class might be instantiated for other types, those will be rejected
    by the code generator.
  ›
  
  class llvm_repv  
    
  class llvm_rep = llvm_repv +
    fixes to_val :: "'a ⇒ llvm_val"
      and from_val :: "llvm_val ⇒ 'a"
      and struct_of :: "'a itself ⇒ llvm_struct"
      and init :: 'a
    assumes from_to_id[simp]: "from_val o to_val = id"
    assumes to_from_id[simp]: "llvm_struct_of_val v = struct_of TYPE('a) ⟹ to_val (from_val v) = v"
    assumes struct_of_matches[simp]: "llvm_struct_of_val (to_val x) = (struct_of TYPE('a))"
    assumes init_zero: "to_val init = llvm_zero_initializer (struct_of TYPE('a))"
    
  begin
  
    lemma from_to_id'[simp]: "from_val (to_val x) = x" 
      using pointfree_idE[OF from_to_id] .
  
    lemma "to_val x = to_val y ⟷ x=y"  
      by (metis from_to_id')
      
  end
  
  text ‹We use a phantom type to attach the type of the pointed to value to a pointer.
    Note that we define pointers for any datatype. While it will always point to 
    representable datatypes, this enables easy ‹llvm_rep› instantiations for recursive structures
    via pointers, such as linked list cells. 
  ›
  
  datatype 'a ptr = PTR (the_raw_ptr: llvm_ptr)
  definition null :: "'a ptr" where "null = PTR PTR_NULL"
  

  text ‹We instantiate the type classes for the supported types, 
    i.e., unit, word, ptr, and prod.›
  
  instance unit :: llvm_repv by standard
  
  instantiation word :: (len) llvm_rep begin
    definition "to_val w ≡ LL_INT (lconst (len_of TYPE('a)) (uint w))"
    definition "from_val v ≡ word_of_int (lint_to_uint (llvm_val.the_int v))"
    definition [simp]: "struct_of_word (_::'a word itself) ≡ VS_INT (len_of TYPE('a))"
    definition [simp]: "init_word ≡ 0::'a word"
    
    
    lemma int_inv_aux: "width i = LENGTH('a) ⟹ lconst LENGTH('a) (uint (word_of_int (lint_to_uint i) :: 'a word)) = i"
      by (metis uint_const uint_eq uint_lower_bound uint_upper_bound width_lconst word_of_int_inverse word_ubin.norm_Rep)
    
    instance
      apply standard
      apply (rule ext)
      apply (simp_all add: from_val_word_def to_val_word_def)
      subgoal for v apply (cases v) using int_inv_aux by auto
      done
      
  end

  instantiation single :: llvm_rep begin
    definition "to_val w ≡ LL_SINGLE w"
    definition "from_val v ≡ llvm_val.the_single v"
    definition [simp]: "struct_of_single (_::single itself) ≡ VS_SINGLE"
    definition [simp]: "init_single ≡ 0::single"

    instance
      apply standard
      apply (simp_all add: fun_eq_iff from_val_single_def to_val_single_def)
      subgoal for v by (cases v; simp)
      done
      
  end
  
  instantiation double :: llvm_rep begin
    definition "to_val w ≡ LL_DOUBLE w"
    definition "from_val v ≡ llvm_val.the_double v"
    definition [simp]: "struct_of_double (_::double itself) ≡ VS_DOUBLE"
    definition [simp]: "init_double ≡ 0::double"

    instance
      apply standard
      apply (simp_all add: fun_eq_iff from_val_double_def to_val_double_def)
      subgoal for v by (cases v; simp)
      done
      
  end
    
  instantiation ptr :: (type) llvm_rep begin
    definition "to_val_ptr ≡ LL_PTR o ptr.the_raw_ptr"
    definition "from_val_ptr v ≡ PTR (llvm_val.the_ptr v)"
    definition [simp]: "struct_of_ptr (_::'a ptr itself) ≡ VS_PTR"
    definition [simp]: "init_ptr::'a ptr ≡ null"
  
    instance
      apply standard
      apply (rule ext)
      apply (simp_all add: from_val_ptr_def to_val_ptr_def null_def)
      subgoal for v apply (cases v) by auto
      done
      
  end
  
  instantiation prod :: (llvm_rep, llvm_rep) llvm_rep begin
    definition "to_val_prod ≡ λ(a,b). LL_STRUCT [to_val a, to_val b]"
    definition "from_val_prod p ≡ case llvm_val.the_fields p of [a,b] ⇒ (from_val a, from_val b)"
    definition [simp]: "struct_of_prod (_::('a×'b) itself) ≡ VS_STRUCT [struct_of TYPE('a), struct_of TYPE('b)]"
    definition [simp]: "init_prod ::'a×'b ≡ (init,init)"
    
    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_prod_def to_val_prod_def init_zero)
      subgoal for v by (cases v) auto
      done
      
  end

  lemma to_val_prod_conv[simp]: "to_val (a,b) = LL_STRUCT [to_val a, to_val b]"
    unfolding to_val_prod_def by auto
  
  context
    includes monad_syntax_M
  begin
    
    
  text ‹Checked conversion from value›  
  definition checked_from_val :: "llvm_val ⇒ 'a::llvm_rep llM" where
    "checked_from_val v ≡ doM {
      assert (llvm_struct_of_val v = struct_of TYPE('a));
      return (from_val v)
    }" 

      
  subsection ‹Instructions›  
  
  text ‹The instructions are arranged in the order as they are described in the 
    LLVM Language Reference Manual 🌐‹https://llvm.org/docs/LangRef.html›.›
    
  
  subsubsection ‹Binary Integer Operations›  
  text ‹We define a generic lifter for binary arithmetic operations.
    It is parameterized by an error condition.
  › (* TODO: Use precondition instead of negated precondition! *)
  
  definition op_lift_arith2 :: "_ ⇒ _ ⇒ 'a::len word ⇒ 'a word ⇒ 'a word llM"
    where "op_lift_arith2 ovf f a b ≡ doM {
    let a = word_to_lint a;
    let b = word_to_lint b;
    assert (¬ovf a b);
    return (lint_to_word (f a b))
  }"
        
  definition "op_lift_arith2' ≡ op_lift_arith2 (λ_ _. False)"

  definition udivrem_is_undef :: "lint ⇒ lint ⇒ bool" 
    where "udivrem_is_undef a b ≡ lint_to_uint b=0"
  definition sdivrem_is_undef :: "lint ⇒ lint ⇒ bool" 
    where "sdivrem_is_undef a b ≡ lint_to_sint b=0 ∨ sdivrem_ovf a b"
  
  definition "ll_add ≡ op_lift_arith2' (+)"
  definition "ll_sub ≡ op_lift_arith2' (-)"
  definition "ll_mul ≡ op_lift_arith2' (*)"
  definition "ll_udiv ≡ op_lift_arith2 udivrem_is_undef (div)"
  definition "ll_urem ≡ op_lift_arith2 udivrem_is_undef (mod)"
  definition "ll_sdiv ≡ op_lift_arith2 sdivrem_is_undef (sdiv)"
  definition "ll_srem ≡ op_lift_arith2 sdivrem_is_undef (smod)"

  subsubsection ‹Binary Floating Point Operations›  
  definition ndet_nan_double :: "double llM" where "ndet_nan_double ≡ Mspec is_nan_double"
  definition ndet_nan_single :: "single llM" where "ndet_nan_single ≡ Mspec is_nan_single"
  
  definition nanize_double where "nanize_double x ≡ if is_nan_double x then ndet_nan_double else return x"
  lemma nanize_double_simps[simp]: 
    "¬is_nan_double x ⟹ nanize_double x = Mreturn x"
    "is_nan_double x ⟹ nanize_double x = ndet_nan_double"
    unfolding nanize_double_def
    by auto

  definition nanize_single where "nanize_single x ≡ if is_nan_single x then ndet_nan_single else return x"
  lemma nanize_single_simps[simp]: 
    "¬is_nan_single x ⟹ nanize_single x = Mreturn x"
    "is_nan_single x ⟹ nanize_single x = ndet_nan_single"
    unfolding nanize_single_def
    by auto
      
  text ‹We define a generic lifter for binary arithmetic operations.
    It is parameterized by an error condition.
  › (* TODO: Use precondition instead of negated precondition! *)
  
  definition op_lift_farith1_d :: "_ ⇒ double ⇒ double llM"
    where "op_lift_farith1_d f a ≡ doM {
    nanize_double (f a)
  }"
  
  definition op_lift_farith2_d :: "_ ⇒ double ⇒ double ⇒ double llM"
    where "op_lift_farith2_d f a b ≡ doM {
    nanize_double (f a b)
  }"

  definition op_lift_farith3_d :: "_ ⇒ double ⇒ double ⇒ double ⇒ double llM"
    where "op_lift_farith3_d f a b c ≡ doM {
    nanize_double (f a b c)
  }"
  
  definition op_lift_farith1_f :: "_ ⇒ single ⇒ single llM"
    where "op_lift_farith1_f f a ≡ doM {
    nanize_single (f a)
  }"
  
  definition op_lift_farith2_f :: "_ ⇒ single ⇒ single ⇒ single llM"
    where "op_lift_farith2_f f a b ≡ doM {
    nanize_single (f a b)
  }"

  definition op_lift_farith3_f :: "_ ⇒ single ⇒ single ⇒ single ⇒ single llM"
    where "op_lift_farith3_f f a b c ≡ doM {
    nanize_single (f a b c)
  }"
          
  definition "ll_fadd_d ≡ op_lift_farith2_d (+)"
  definition "ll_fsub_d ≡ op_lift_farith2_d (-)"
  definition "ll_fmul_d ≡ op_lift_farith2_d (*)"
  definition "ll_fdiv_d ≡ op_lift_farith2_d (/)"
  definition "ll_frem_d ≡ op_lift_farith2_d (drem)"     
  definition "ll_sqrt_f64 ≡ op_lift_farith1_d (dsqrt)"

  definition "ll_fadd_f ≡ op_lift_farith2_f (+)"
  definition "ll_fsub_f ≡ op_lift_farith2_f (-)"
  definition "ll_fmul_f ≡ op_lift_farith2_f (*)"
  definition "ll_fdiv_f ≡ op_lift_farith2_f (/)"
  definition "ll_frem_f ≡ op_lift_farith2_f (srem)"     
  definition "ll_sqrt_f32 ≡ op_lift_farith1_f (ssqrt)"
    
  subsubsection ‹Compare Operations›
  definition op_lift_cmp :: "_ ⇒ 'a::len word ⇒ 'a word ⇒ 1 word llM"
    where "op_lift_cmp f a b ≡ doM {
    let a = word_to_lint a;
    let b = word_to_lint b;
    return (lint_to_word (bool_to_lint (f a b)))
  }"
    
  definition "ll_icmp_eq ≡  op_lift_cmp (=)"
  definition "ll_icmp_ne ≡  op_lift_cmp (≠)"
  definition "ll_icmp_sle ≡ op_lift_cmp (≤s)"
  definition "ll_icmp_slt ≡ op_lift_cmp (<s)"
  definition "ll_icmp_ule ≡ op_lift_cmp (≤)"
  definition "ll_icmp_ult ≡ op_lift_cmp (<)"

  subsubsection ‹Floating Point Compare Operations›
  definition op_lift_fcmp_d :: "bool ⇒ _ ⇒ double ⇒ double ⇒ 1 word llM"
    where "op_lift_fcmp_d ordered f a b ≡ doM {
      if ordered then
        return (lint_to_word (bool_to_lint (¬is_nan_double a ∧ ¬is_nan_double b ∧ f a b)))
      else
        return (lint_to_word (bool_to_lint (is_nan_double a ∨ is_nan_double b ∨ f a b)))
    
  }"
  definition op_lift_fcmp_f :: "bool ⇒ _ ⇒ single ⇒ single ⇒ 1 word llM"
    where "op_lift_fcmp_f ordered f a b ≡ doM {
      if ordered then
        return (lint_to_word (bool_to_lint (¬is_nan_single a ∧ ¬is_nan_single b ∧ f a b)))
      else
        return (lint_to_word (bool_to_lint (is_nan_single a ∨ is_nan_single b ∨ f a b)))
    
  }"
    
  (* from the LLVM docs: (we skip true and false here, as they are not required for our purpose )
    oeq: yields true if both operands are not a QNAN and op1 is equal to op2.
    ogt: yields true if both operands are not a QNAN and op1 is greater than op2.
    oge: yields true if both operands are not a QNAN and op1 is greater than or equal to op2.
    olt: yields true if both operands are not a QNAN and op1 is less than op2.
    ole: yields true if both operands are not a QNAN and op1 is less than or equal to op2.
    one: yields true if both operands are not a QNAN and op1 is not equal to op2.
    ord: yields true if both operands are not a QNAN.
    ueq: yields true if either operand is a QNAN or op1 is equal to op2.
    ugt: yields true if either operand is a QNAN or op1 is greater than op2.
    uge: yields true if either operand is a QNAN or op1 is greater than or equal to op2.
    ult: yields true if either operand is a QNAN or op1 is less than op2.
    ule: yields true if either operand is a QNAN or op1 is less than or equal to op2.
    une: yields true if either operand is a QNAN or op1 is not equal to op2.
    uno: yields true if either operand is a QNAN.
  *)
  
  definition "ll_fcmp_oeq_d ≡ op_lift_fcmp_d True (eq_double)"
  definition "ll_fcmp_ogt_d ≡ op_lift_fcmp_d True (>)"
  definition "ll_fcmp_oge_d ≡ op_lift_fcmp_d True (≥)"
  definition "ll_fcmp_olt_d ≡ op_lift_fcmp_d True (<)"
  definition "ll_fcmp_ole_d ≡ op_lift_fcmp_d True (≤)"
  definition "ll_fcmp_one_d ≡ op_lift_fcmp_d True (Not oo eq_double)"
  definition "ll_fcmp_ord_d ≡ op_lift_fcmp_d True (λ_ _. True)"

  definition "ll_fcmp_ueq_d ≡ op_lift_fcmp_d False (eq_double)"
  definition "ll_fcmp_ugt_d ≡ op_lift_fcmp_d False (>)"
  definition "ll_fcmp_uge_d ≡ op_lift_fcmp_d False (≥)"
  definition "ll_fcmp_ult_d ≡ op_lift_fcmp_d False (<)"
  definition "ll_fcmp_ule_d ≡ op_lift_fcmp_d False (≤)"
  definition "ll_fcmp_une_d ≡ op_lift_fcmp_d False (Not oo eq_double)"
  definition "ll_fcmp_uno_d ≡ op_lift_fcmp_d False (λ_ _. False)"
  
  definition "ll_fcmp_oeq_f ≡ op_lift_fcmp_f True (eq_single)"
  definition "ll_fcmp_ogt_f ≡ op_lift_fcmp_f True (>)"
  definition "ll_fcmp_oge_f ≡ op_lift_fcmp_f True (≥)"
  definition "ll_fcmp_olt_f ≡ op_lift_fcmp_f True (<)"
  definition "ll_fcmp_ole_f ≡ op_lift_fcmp_f True (≤)"
  definition "ll_fcmp_one_f ≡ op_lift_fcmp_f True (Not oo eq_single)"
  definition "ll_fcmp_ord_f ≡ op_lift_fcmp_f True (λ_ _. True)"

  definition "ll_fcmp_ueq_f ≡ op_lift_fcmp_f False (eq_single)"
  definition "ll_fcmp_ugt_f ≡ op_lift_fcmp_f False (>)"
  definition "ll_fcmp_uge_f ≡ op_lift_fcmp_f False (≥)"
  definition "ll_fcmp_ult_f ≡ op_lift_fcmp_f False (<)"
  definition "ll_fcmp_ule_f ≡ op_lift_fcmp_f False (≤)"
  definition "ll_fcmp_une_f ≡ op_lift_fcmp_f False (Not oo eq_single)"
  definition "ll_fcmp_uno_f ≡ op_lift_fcmp_f False (λ_ _. False)"
  
  subsubsection "AVX512f: sd-operations with rounding mode"
  text ‹The code generator creates the insertion/extraction into vector type.›
  (* TODO: Add vector type to memory model! *)

  (*Rounding mode constants, from LLVM's smmintrin.h:
  
    #define _MM_FROUND_TO_NEAREST_INT    0x00
    #define _MM_FROUND_TO_NEG_INF        0x01
    #define _MM_FROUND_TO_POS_INF        0x02
    #define _MM_FROUND_TO_ZERO           0x03
    #define _MM_FROUND_CUR_DIRECTION     0x04
    
    #define _MM_FROUND_RAISE_EXC         0x00
    #define _MM_FROUND_NO_EXC            0x08
  *) 
  
  abbreviation (input) "AVX512_MM_FROUND_TO_NEAREST_INT ≡ 0x00 :: nat"
  abbreviation (input) "AVX512_MM_FROUND_TO_NEG_INF     ≡ 0x01 :: nat"
  abbreviation (input) "AVX512_MM_FROUND_TO_POS_INF     ≡ 0x02 :: nat"
  abbreviation (input) "AVX512_MM_FROUND_TO_ZERO        ≡ 0x03 :: nat"
  abbreviation (input) "AVX512_MM_FROUND_CUR_DIRECTION  ≡ 0x04 :: nat"   
  
  abbreviation (input) "AVX512_MM_FROUND_RAISE_EXC      ≡ 0x00 :: nat"
  abbreviation (input) "AVX512_MM_FROUND_NO_EXC         ≡ 0x08 :: nat"
  
  (* We support the following combinations (from Intel's Intrinsics guide, without CUR_DIRECTION)
    (_MM_FROUND_TO_NEAREST_INT |_MM_FROUND_NO_EXC) // round to nearest, and suppress exceptions
    (_MM_FROUND_TO_NEG_INF |_MM_FROUND_NO_EXC)     // round down, and suppress exceptions
    (_MM_FROUND_TO_POS_INF |_MM_FROUND_NO_EXC)     // round up, and suppress exceptions
    (_MM_FROUND_TO_ZERO |_MM_FROUND_NO_EXC)        // truncate, and suppress exceptions
    
  *)

  abbreviation (input) "AVX512_FROUND_TO_NEAREST_NO_EXC ≡ 0x08 :: nat"
  abbreviation (input) "AVX512_FROUND_TO_NEG_INF_NO_EXC ≡ 0x09 :: nat"
  abbreviation (input) "AVX512_FROUND_TO_POS_INF_NO_EXC ≡ 0x0A :: nat"
  abbreviation (input) "AVX512_FROUND_TO_ZERO_NO_EXC ≡ 0x0B :: nat"

  (* Alternative definitions, showing consistency! *)  
  lemma "AVX512_FROUND_TO_NEAREST_NO_EXC = AVX512_MM_FROUND_TO_NEAREST_INT OR AVX512_MM_FROUND_NO_EXC" by eval
  lemma "AVX512_FROUND_TO_NEG_INF_NO_EXC = AVX512_MM_FROUND_TO_NEG_INF OR AVX512_MM_FROUND_NO_EXC" by eval
  lemma "AVX512_FROUND_TO_POS_INF_NO_EXC = AVX512_MM_FROUND_TO_POS_INF OR AVX512_MM_FROUND_NO_EXC" by eval
  lemma "AVX512_FROUND_TO_ZERO_NO_EXC = AVX512_MM_FROUND_TO_ZERO OR AVX512_MM_FROUND_NO_EXC" by eval

  definition xlate_rounding_mode :: "nat ⇒ roundmode llM" where "xlate_rounding_mode rm ≡ 
         if rm = AVX512_FROUND_TO_NEAREST_NO_EXC then return To_nearest
    else if rm = AVX512_FROUND_TO_NEG_INF_NO_EXC then return To_ninfinity
    else if rm = AVX512_FROUND_TO_POS_INF_NO_EXC then return To_pinfinity
    else if rm = AVX512_FROUND_TO_ZERO_NO_EXC then return float_To_zero
    else fail"
    
  lemma xlate_rounding_mode_simps:  
    "xlate_rounding_mode AVX512_FROUND_TO_NEAREST_NO_EXC = (return To_nearest)"
    "xlate_rounding_mode AVX512_FROUND_TO_NEG_INF_NO_EXC = (return To_ninfinity)"
    "xlate_rounding_mode AVX512_FROUND_TO_POS_INF_NO_EXC = (return To_pinfinity)"
    "xlate_rounding_mode AVX512_FROUND_TO_ZERO_NO_EXC = (return float_To_zero)"
    unfolding xlate_rounding_mode_def by simp_all
    
  definition op_lift_farith1_rm_d :: "(roundmode ⇒ double ⇒ double) ⇒ nat ⇒ double ⇒ double llM" 
    where "op_lift_farith1_rm_d f rm a ≡ doM { rm ← xlate_rounding_mode rm; nanize_double (f rm a) }"
  definition op_lift_farith2_rm_d :: "(roundmode ⇒ double ⇒ double ⇒ double) ⇒ nat ⇒ double ⇒ double ⇒ double llM" 
    where "op_lift_farith2_rm_d f rm a b ≡ doM { rm ← xlate_rounding_mode rm; nanize_double (f rm a b) }"
  definition op_lift_farith3_rm_d :: "(roundmode ⇒ double ⇒ double ⇒ double ⇒ double) ⇒ nat ⇒ double ⇒ double ⇒ double ⇒ double llM" 
    where "op_lift_farith3_rm_d f rm a b c ≡ doM { rm ← xlate_rounding_mode rm; nanize_double (f rm a b c) }"

  definition op_lift_farith1_rm_f :: "(roundmode ⇒ single ⇒ single) ⇒ nat ⇒ single ⇒ single llM" 
    where "op_lift_farith1_rm_f f rm a ≡ doM { rm ← xlate_rounding_mode rm; nanize_single (f rm a) }"
  definition op_lift_farith2_rm_f :: "(roundmode ⇒ single ⇒ single ⇒ single) ⇒ nat ⇒ single ⇒ single ⇒ single llM" 
    where "op_lift_farith2_rm_f f rm a b ≡ doM { rm ← xlate_rounding_mode rm; nanize_single (f rm a b) }"
  definition op_lift_farith3_rm_f :: "(roundmode ⇒ single ⇒ single ⇒ single ⇒ single) ⇒ nat ⇒ single ⇒ single ⇒ single ⇒ single llM" 
    where "op_lift_farith3_rm_f f rm a b c ≡ doM { rm ← xlate_rounding_mode rm; nanize_single (f rm a b c) }"
    
        
  definition "ll_x86_avx512_add_sd_round ≡ op_lift_farith2_rm_d dradd"
  definition "ll_x86_avx512_sub_sd_round ≡ op_lift_farith2_rm_d drsub"
  definition "ll_x86_avx512_mul_sd_round ≡ op_lift_farith2_rm_d drmul"
  definition "ll_x86_avx512_div_sd_round ≡ op_lift_farith2_rm_d drdiv"
  definition "ll_x86_avx512_sqrt_sd ≡ op_lift_farith1_rm_d drsqrt"
  definition "ll_x86_avx512_vfmadd_f64 ≡ op_lift_farith3_rm_d drfmadd"

  definition "ll_x86_avx512_add_ss_round ≡ op_lift_farith2_rm_f sradd"
  definition "ll_x86_avx512_sub_ss_round ≡ op_lift_farith2_rm_f srsub"
  definition "ll_x86_avx512_mul_ss_round ≡ op_lift_farith2_rm_f srmul"
  definition "ll_x86_avx512_div_ss_round ≡ op_lift_farith2_rm_f srdiv"
  definition "ll_x86_avx512_sqrt_ss ≡ op_lift_farith1_rm_f srsqrt"
  definition "ll_x86_avx512_vfmadd_f32 ≡ op_lift_farith3_rm_f srfmadd"
  
  subsubsection ‹Bitwise Binary Operations›                                      
  definition "shift_ovf a n ≡ nat (lint_to_uint n) ≥ width a"
  definition "bitSHL' a n ≡ bitSHL a (nat (lint_to_uint n))"
  definition "bitASHR' a n ≡ bitASHR a (nat (lint_to_uint n))"
  definition "bitLSHR' a n ≡ bitLSHR a (nat (lint_to_uint n))"
  
  definition "ll_shl ≡ op_lift_arith2 shift_ovf bitSHL'"  
  definition "ll_lshr ≡ op_lift_arith2 shift_ovf bitLSHR'"  
  definition "ll_ashr ≡ op_lift_arith2 shift_ovf bitASHR'"
  
  definition "ll_and ≡ op_lift_arith2' (lliAND)"
  definition "ll_or ≡ op_lift_arith2' (lliOR)"
  definition "ll_xor ≡ op_lift_arith2' (lliXOR)"
    

  subsubsection ‹Aggregate Operations›
  text ‹In LLVM, there is an ‹extractvalue› and ‹insertvalue› operation.
    In our shallow embedding, these get instantiated for ‹fst› and ‹snd›.›
    
    
  definition ll_extract_value :: "'t::llvm_rep ⇒ nat ⇒ 't1::llvm_rep llM"
    where "ll_extract_value p i ≡ doM {
      r ← llvm_extract_value (to_val p) i;
      checked_from_val r
    }"  
    
  definition ll_insert_value :: "'t::llvm_rep ⇒ 't1::llvm_rep ⇒ nat ⇒ 't::llvm_rep llM"
    where "ll_insert_value p x i ≡ doM {
      r ← llvm_insert_value (to_val p) (to_val x) i;
      checked_from_val r
    }"
    
  definition ll_dest_union :: "'t::llvm_rep ⇒ nat ⇒ 't1::llvm_rep llM" 
    where "ll_dest_union p i ≡ doM {
      r ← llvm_dest_union (to_val p) i;
      checked_from_val r
    }" 

  definition ll_make_union :: "'t::llvm_rep itself ⇒ 't1::llvm_rep ⇒ nat ⇒ 't::llvm_rep llM"
    where "ll_make_union TYPE('t) x i ≡ doM {
      r ← llvm_make_union (struct_of TYPE('t)) (to_val x) i;
      checked_from_val r
    }"
        
    
  subsubsection ‹Memory Access and Addressing Operations›
    
  definition ll_load :: "'a::llvm_rep ptr ⇒ 'a llM" where
    "ll_load p ≡ doM {
      r ← llvm_load (to_val p);
      checked_from_val r
    }"
    
  definition ll_store :: "'a::llvm_rep ⇒ 'a ptr ⇒ unit llM" where
    "ll_store v p ≡ doM {
      llvm_store (to_val v) (to_val p)
    }"

  text ‹Note that LLVM itself does not have malloc and free instructions.
    However, these are primitive instructions in our abstract memory model, 
    such that we have to model them in our semantics.
    
    The code generator will map them to the C standard library 
    functions ‹calloc› and ‹free›.
  ›
    
  definition ll_malloc :: "'a::llvm_rep itself ⇒ _::len word ⇒ 'a ptr llM" where
    "ll_malloc TYPE('a) n = doM {
      assert (unat n > 0); ― ‹Disallow empty malloc›
      r ← llvm_alloc (struct_of TYPE ('a)) (to_val n);
      return (from_val r)
    }"
        
  definition ll_free :: "'a::llvm_rep ptr ⇒ unit llM" 
    where "ll_free p ≡ doM {
      llvm_free (to_val p)
    }"


  text ‹As for the aggregate operations, the ‹getelementptr› instruction is instantiated 
    for pointer and structure indexing. ›
      
  definition ll_ofs_ptr :: "'a::llvm_rep ptr ⇒ _::len word ⇒ 'a ptr llM" where "ll_ofs_ptr p ofs = doM {
    r ← llvm_ofs_ptr (to_val p) (to_val ofs);
    return (from_val r)
  }"  

  (* disabled in simple memory model
  definition ll_gep_struct :: "'p::llvm_rep ptr ⇒ nat ⇒ 'a::llvm_rep ptr llM" where "ll_gep_struct p i = doM {
    fcheck (STATIC_ERROR ''gep_struct: Expected struct type'') (llvm_is_s_struct (struct_of TYPE('p)));
    r ← llvm_checked_gep (the_raw_ptr p) (PFLD i);
    return (PTR r)
  }"
  *)

  subsubsection ‹Pointer Comparison›  
  text ‹Note: There are no pointer comparison instructions in LLVM. 
    To compare pointers in LLVM, they have to be casted to integers first.
    However, our abstract memory model cannot assign a bit-width to pointers.
    
    Thus, we model pointer comparison instructions in our semantics, and let the 
    code generator translate them to integer comparisons. 
    
    Up to now, we only model pointer equality. 
    
    Note that the operand pointers must be null, or point to currently allocated memory.
    
    For less-than, more preconditions are required, which are consistent with the 
    actual memory layout of LLVM. We could, e.g., adopt the rules from the C standard here.
  ›
  
  text ‹Check if a pair of pointers is valid for comparison operation, i.e., one is null or both are currently allocated›
  (*definition check_ptrs_cmp :: "'a::llvm_rep ptr ⇒ 'a ptr ⇒ unit llM" where
    "check_ptrs_cmp p1 p2 ≡ if p1=null ∨ p2=null then return () else doM { ll_load p1; ll_load p2; return ()}"
  
  definition op_lift_ptr_cmp :: "_ ⇒ 'a::llvm_rep ptr ⇒ 'a ptr ⇒ 1 word llM"
    where "op_lift_ptr_cmp f a b ≡ doM {
    check_ptrs_cmp a b;  
    return (lint_to_word (bool_to_lint (f a b)))
  }"*)
  
  definition ll_ptrcmp_eq :: "'a ptr ⇒ 'a ptr ⇒ 1 word llM" where "ll_ptrcmp_eq a b ≡ doM {
    r ← llvm_ptr_eq (to_val a) (to_val b);
    return (from_val r)
  }"
  definition ll_ptrcmp_ne :: "'a ptr ⇒ 'a ptr ⇒ 1 word llM" where "ll_ptrcmp_ne a b ≡ doM {
    r ← llvm_ptr_neq (to_val a) (to_val b);
    return (from_val r)
  }"
  
  subsubsection ‹Conversion Operations›
  definition "llb_trunc i w ≡ doM {
    assert (width i > w);
    return (trunc w i)
  }"
  
  definition "llb_sext i w ≡ doM {
    assert (width i < w);
    return (sext w i)
  }"
  
  definition "llb_zext i w ≡ doM {
    assert (width i < w);
    return (zext w i)
  }"
  
  definition op_lift_iconv :: "_ ⇒ 'a::len word ⇒ 'b::len word itself  ⇒ 'b word llM"
    where "op_lift_iconv f a _ ≡ doM {
    let a = word_to_lint a;
    let w = LENGTH('b);
    r ← f a w;
    return (lint_to_word r)
  }"
  
  definition "ll_trunc ≡ op_lift_iconv llb_trunc"
  definition "ll_sext ≡ op_lift_iconv llb_sext"
  definition "ll_zext ≡ op_lift_iconv llb_zext"
  
    
        
        
  subsection ‹Control Flow›  

  text ‹Our shallow embedding uses a structured control flow, which allows
    only sequential composition, if-then-else, and function calls.
    
    The code generator then maps sequential composition to basic blocks, 
    and if-then-else to a control flow graph with conditional branching.
    Function calls are mapped to LLVM function calls.  
   ›
  
  text ‹We use the to Boolean conversion from word-lib. We re-state its semantics here.›
    
  lemma to_bool_as_lint_to_bool:
    "to_bool (w::1 word) = lint_to_bool (word_to_lint w)"
    unfolding to_bool_def word_to_lint_def
    apply (clarsimp simp: ltrue_def lfalse_def lint_to_bool_def)
    apply transfer
    apply auto
    done
  
  lemma to_bool_eq[simp]: "to_bool (w::1 word) ⟷ w≠0"
    by (rule to_bool_neq_0)
  
  definition llc_if :: "1 word ⇒ 'a::llvm_repv llM ⇒ 'a llM ⇒ 'a llM" where
    "llc_if b t e ≡ doM {
      if to_bool b then t else e
    }"
  
  lemma mono_llc_If[partial_function_mono]: "
    ⟦ M_mono' (λD. F D); M_mono' (λD. G D) ⟧ ⟹
    M_mono' (λD. llc_if b (F D) (G D))"  
    unfolding llc_if_def by pf_mono_prover
    
  subsubsection ‹Parallel Combinator›  
  definition llc_par :: "('a ⇒ 'ar llM) ⇒ ('b ⇒ 'br llM) ⇒ 'a ⇒ 'b ⇒ ('ar × 'br) llM" where 
    "llc_par f g a b ≡ Mpar (f a) (g b)"

  lemma mono_llc_par[partial_function_mono]: "
    ⟦⋀x. M_mono' (λD. F D x); ⋀x. M_mono' (λD. G D x) ⟧
    ⟹ M_mono' (λD. llc_par (F D) (G D) x1 x2)"
    unfolding llc_par_def 
    by pf_mono_prover
    
  subsubsection ‹While-Combinator›
  text ‹
    Note: later in this development, we introduce a flag to control direct translation.
      If disabled, the code generator will refuse to accept while, but the 
      preprocessor will transform it into a tail recursive function.
  ›
    
  definition llc_while :: "('a::llvm_repv ⇒ 1 word llM) ⇒ ('a ⇒ 'a llM) ⇒ 'a ⇒ 'a llM" where
    "llc_while b f s0 ≡ Mwhile (λs. doM {bb ← b s; return to_bool bb}) f s0"
      
  lemma gen_code_thm_llc_while:
    assumes "f ≡ llc_while b body"
    shows "f s = doM { ctd ← b s; llc_if ctd (doM { s←body s; f s}) (return s)}"
    unfolding assms
    unfolding llc_while_def llc_if_def
    apply (rewrite Mwhile_unfold)
    by simp

  lemma llc_while_mono[partial_function_mono]:      
    assumes "⋀x. M_mono' (λf. b f x)"
    assumes "⋀x. M_mono' (λf. c f x)"
    shows "M_mono' (λD. llc_while (b D) (c D) σ)"
    using assms unfolding llc_while_def 
    by pf_mono_prover
    
  (* 'Definition' of llc_while for presentation in paper: *)  
  lemma "llc_while b c s ≡ doM { x ← b s; llc_if x (doM {s←c s; llc_while b c s}) (return s) }"
    unfolding llc_while_def llc_if_def
    apply (rewrite Mwhile_unfold)
    by simp
    
      
    
end
end