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)  w0"
    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 { sbody 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 {sc s; llc_while b c s}) (return s) }"
    unfolding llc_while_def llc_if_def
    apply (rewrite Mwhile_unfold)
    by simp
    
      
    
end
end