source: driver/extracted/eRTL_semantics.ml @ 3106

open Preamble

open ExtraMonads

open Deqsets_extra

open State

open Bind_new

open BindLists

open Blocks

open TranslateUtils

open ExtraGlobalenvs

open I8051bis

open String

open Sets

open Listb

open LabelledObjects

open BitVectorTrie

open Graphs

open I8051

open Order

open Registers

open BackEndOps

open Joint

open BEMem

open CostLabel

open Events

open IOMonad

open IO

open Extra_bool

open Coqlib

open Values

open FrontEndVal

open Hide

open ByteValues

open Division

open Z

open BitVectorZ

open Pointers

open GenMem

open FrontEndMem

open Proper

open PositiveMap

open Deqsets

open Extralib

open Lists

open Identifiers

open Exp

open Arithmetic

open Vector

open Div_and_mod

open Util

open FoldStuff

open BitVector

open Extranat

open Integers

open AST

open ErrorMessages

open Option

open Setoids

open Monad

open Jmeq

open Russell

open Positive

open PreIdentifiers

open Bool

open Relations

open Nat

open List

open Hints_declaration

open Core_notation

open Pts

open Logic

open Types

open Errors

open Globalenvs

open Joint_semantics

open SemanticsUtils

open ERTL

type ertl_reg_env =
  (ByteValues.beval Registers.register_env, SemanticsUtils.hw_register_env)
  Types.prod

(** val ps_reg_store :
    PreIdentifiers.identifier -> ByteValues.beval -> ertl_reg_env ->
    (ByteValues.beval Identifiers.identifier_map,
    SemanticsUtils.hw_register_env) Types.prod Errors.res **)
let ps_reg_store r v local_env =
  let res = SemanticsUtils.reg_store r v local_env.Types.fst in
  Errors.OK { Types.fst = res; Types.snd = local_env.Types.snd }

(** val ps_reg_retrieve :
    ertl_reg_env -> Registers.register -> ByteValues.beval Errors.res **)
let ps_reg_retrieve local_env =
  SemanticsUtils.reg_retrieve local_env.Types.fst

(** val hw_reg_store :
    I8051.register -> ByteValues.beval -> ertl_reg_env -> (ByteValues.beval
    Registers.register_env, SemanticsUtils.hw_register_env) Types.prod
    Errors.res **)
let hw_reg_store r v local_env =
  Errors.OK { Types.fst = local_env.Types.fst; Types.snd =
    (SemanticsUtils.hwreg_store r v local_env.Types.snd) }

(** val hw_reg_retrieve :
    ertl_reg_env -> I8051.register -> ByteValues.beval Errors.res **)
let hw_reg_retrieve local_env reg =
  Errors.OK (SemanticsUtils.hwreg_retrieve local_env.Types.snd reg)

(** val ps_arg_retrieve :
    ertl_reg_env -> Registers.register Joint.argument -> ByteValues.beval
    Errors.res **)
let ps_arg_retrieve local_env = function
| Joint.Reg r -> ps_reg_retrieve local_env r
| Joint.Imm b ->
  Obj.magic
    (Monad.m_return0 (Monad.max_def Errors.res0) (ByteValues.BVByte b))

(** val get_hwsp : ertl_reg_env -> ByteValues.xpointer Errors.res **)
let get_hwsp st =
  SemanticsUtils.hwreg_retrieve_sp st.Types.snd

(** val set_hwsp : ertl_reg_env -> ByteValues.xpointer -> ertl_reg_env **)
let set_hwsp st sp =
  { Types.fst = st.Types.fst; Types.snd =
    (SemanticsUtils.hwreg_store_sp st.Types.snd sp) }

(** val eRTL_state : Joint_semantics.sem_state_params **)
let eRTL_state =
  { Joint_semantics.empty_framesT = (Obj.magic List.Nil);
    Joint_semantics.empty_regsT = (fun sp ->
    Obj.magic { Types.fst =
      (Identifiers.empty_map PreIdentifiers.RegisterTag); Types.snd =
      (SemanticsUtils.init_hw_register_env sp) }); Joint_semantics.load_sp =
    (Obj.magic get_hwsp); Joint_semantics.save_sp = (Obj.magic set_hwsp) }

(** val ertl_eval_move :
    ertl_reg_env -> (ERTL.move_dst, ERTL.move_dst Joint.argument) Types.prod
    -> __ **)
let ertl_eval_move env pr =
  Monad.m_bind0 (Monad.max_def Errors.res0)
    (match pr.Types.snd with
     | Joint.Reg src ->
       (match src with
        | ERTL.PSD r -> Obj.magic (ps_reg_retrieve env r)
        | ERTL.HDW r -> Obj.magic (hw_reg_retrieve env r))
     | Joint.Imm b ->
       Monad.m_return0 (Monad.max_def Errors.res0) (ByteValues.BVByte b))
    (fun v ->
    match pr.Types.fst with
    | ERTL.PSD r -> Obj.magic (ps_reg_store r v env)
    | ERTL.HDW r -> Obj.magic (hw_reg_store r v env))

(** val ertl_allocate_local :
    PreIdentifiers.identifier -> ertl_reg_env -> (ByteValues.beval
    Identifiers.identifier_map, SemanticsUtils.hw_register_env) Types.prod **)
let ertl_allocate_local reg lenv =
  { Types.fst =
    (Identifiers.add PreIdentifiers.RegisterTag lenv.Types.fst reg
      ByteValues.BVundef); Types.snd = lenv.Types.snd }

(** val ertl_save_frame :
    Joint_semantics.call_kind -> Types.unit0 -> Joint_semantics.state_pc ->
    Joint_semantics.state Errors.res **)
let ertl_save_frame x x0 st =
  Obj.magic
    (Monad.m_bind0 (Monad.max_def Errors.res0)
      (Obj.magic
        (Joint_semantics.push_ra eRTL_state st.Joint_semantics.st_no_pc
          st.Joint_semantics.pc)) (fun st' ->
      Monad.m_bind0 (Monad.max_def Errors.res0)
        (Obj.magic
          (Errors.opt_to_res (List.Cons ((Errors.MSG
            ErrorMessages.FrameErrorOnPush), List.Nil))
            st'.Joint_semantics.st_frms)) (fun frms ->
        Monad.m_return0 (Monad.max_def Errors.res0)
          (Joint_semantics.set_frms eRTL_state
            (Obj.magic (List.Cons ({ Types.fst =
              (Obj.magic st'.Joint_semantics.regs).Types.fst; Types.snd =
              st.Joint_semantics.pc.ByteValues.pc_block }, frms)))
            (Joint_semantics.set_regs eRTL_state
              (Obj.magic { Types.fst =
                (Identifiers.empty_map PreIdentifiers.RegisterTag);
                Types.snd = (Obj.magic st'.Joint_semantics.regs).Types.snd })
              st')))))

(** val ertl_pop_frame :
    Joint_semantics.state -> (Joint_semantics.state,
    ByteValues.program_counter) Types.prod Errors.res **)
let ertl_pop_frame st =
  Obj.magic
    (Monad.m_bind0 (Monad.max_def Errors.res0)
      (Obj.magic
        (Errors.opt_to_res (List.Cons ((Errors.MSG
          ErrorMessages.FrameErrorOnPop), List.Nil))
          st.Joint_semantics.st_frms)) (fun frms ->
      match frms with
      | List.Nil ->
        Obj.magic (Errors.Error (List.Cons ((Errors.MSG
          ErrorMessages.FramesEmptyOnPop), List.Nil)))
      | List.Cons (hd, tl) ->
        let { Types.fst = local_mem; Types.snd = bl } = hd in
        let st' =
          Joint_semantics.set_regs eRTL_state
            (Obj.magic { Types.fst = local_mem; Types.snd =
              (Obj.magic st.Joint_semantics.regs).Types.snd })
            (Joint_semantics.set_frms eRTL_state (Obj.magic tl) st)
        in
        Monad.m_bind2 (Monad.max_def Errors.res0)
          (Obj.magic (Joint_semantics.pop_ra eRTL_state st')) (fun st'' pc ->
          match Pointers.eq_block (Types.pi1 bl)
                  (Types.pi1 pc.ByteValues.pc_block) with
          | Bool.True ->
            Obj.magic (Errors.OK { Types.fst = st''; Types.snd = pc })
          | Bool.False ->
            Obj.magic (Errors.Error (List.Cons ((Errors.MSG
              ErrorMessages.BlockInFramesCorrupted), List.Nil))))))

(** val ertl_fetch_external_args :
    AST.external_function -> Joint_semantics.state -> __ -> Values.val0
    List.list Errors.res **)
let ertl_fetch_external_args _ =
  failwith "AXIOM TO BE REALIZED"

(** val ertl_set_result :
    Values.val0 List.list -> Types.unit0 -> Joint_semantics.state ->
    Joint_semantics.state Errors.res **)
let ertl_set_result _ =
  failwith "AXIOM TO BE REALIZED"

(** val ps_reg_store_status :
    Registers.register -> ByteValues.beval -> Joint_semantics.state ->
    Joint_semantics.state Errors.res **)
let ps_reg_store_status dst v st =
  let env = st.Joint_semantics.regs in
  Obj.magic
    (Monad.m_bind0 (Monad.max_def Errors.res0)
      (Obj.magic (ps_reg_store dst v (Obj.magic env))) (fun env' ->
      Monad.m_return0 (Monad.max_def Errors.res0)
        (Joint_semantics.set_regs eRTL_state env' st)))

(** val eval_ertl_seq :
    AST.ident List.list -> 'a1 Joint_semantics.genv_gen -> ERTL.ertl_seq ->
    AST.ident -> Joint_semantics.state -> Joint_semantics.state Errors.res **)
let eval_ertl_seq globals ge stm id st =
  Obj.magic
    (Monad.m_bind0 (Monad.max_def Errors.res0)
      (Obj.magic
        (Errors.opt_to_res (Errors.msg ErrorMessages.FunctionNotFound)
          (ge.Joint_semantics.stack_sizes id))) (fun framesize ->
      let framesize0 =
        Arithmetic.bitvector_of_nat (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
          (Nat.S (Nat.S Nat.O)))))))) framesize
      in
      (match stm with
       | ERTL.Ertl_new_frame ->
         Monad.m_bind0 (Monad.max_def Errors.res0)
           (Obj.magic (Joint_semantics.sp eRTL_state st)) (fun sp ->
           let newsp =
             Pointers.neg_shift_pointer (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
               (Nat.S (Nat.S (Nat.S Nat.O)))))))) (Types.pi1 sp) framesize0
           in
           Monad.m_return0 (Monad.max_def Errors.res0)
             (Joint_semantics.set_sp eRTL_state newsp st))
       | ERTL.Ertl_del_frame ->
         Monad.m_bind0 (Monad.max_def Errors.res0)
           (Obj.magic (Joint_semantics.sp eRTL_state st)) (fun sp ->
           let newsp =
             Pointers.shift_pointer (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S (Nat.S
               (Nat.S (Nat.S Nat.O)))))))) (Types.pi1 sp) framesize0
           in
           Monad.m_return0 (Monad.max_def Errors.res0)
             (Joint_semantics.set_sp eRTL_state newsp st))
       | ERTL.Ertl_frame_size dst ->
         Obj.magic
           (ps_reg_store_status dst (ByteValues.BVByte framesize0) st))))

(** val eRTL_sem_uns : 'a1 Joint_semantics.sem_unserialized_params **)
let eRTL_sem_uns =
  { Joint_semantics.st_pars = eRTL_state; Joint_semantics.acca_store_ =
    (Obj.magic ps_reg_store); Joint_semantics.acca_retrieve_ =
    (Obj.magic ps_reg_retrieve); Joint_semantics.acca_arg_retrieve_ =
    (Obj.magic ps_arg_retrieve); Joint_semantics.accb_store_ =
    (Obj.magic ps_reg_store); Joint_semantics.accb_retrieve_ =
    (Obj.magic ps_reg_retrieve); Joint_semantics.accb_arg_retrieve_ =
    (Obj.magic ps_arg_retrieve); Joint_semantics.dpl_store_ =
    (Obj.magic ps_reg_store); Joint_semantics.dpl_retrieve_ =
    (Obj.magic ps_reg_retrieve); Joint_semantics.dpl_arg_retrieve_ =
    (Obj.magic ps_arg_retrieve); Joint_semantics.dph_store_ =
    (Obj.magic ps_reg_store); Joint_semantics.dph_retrieve_ =
    (Obj.magic ps_reg_retrieve); Joint_semantics.dph_arg_retrieve_ =
    (Obj.magic ps_arg_retrieve); Joint_semantics.snd_arg_retrieve_ =
    (Obj.magic ps_arg_retrieve); Joint_semantics.pair_reg_move_ =
    (Obj.magic ertl_eval_move); Joint_semantics.save_frame =
    (Obj.magic ertl_save_frame); Joint_semantics.setup_call =
    (fun x x0 x1 st ->
    Obj.magic (Monad.m_return0 (Monad.max_def Errors.res0) st));
    Joint_semantics.fetch_external_args = ertl_fetch_external_args;
    Joint_semantics.set_result = (Obj.magic ertl_set_result);
    Joint_semantics.call_args_for_main = (Obj.magic Nat.O);
    Joint_semantics.call_dest_for_main = (Obj.magic Types.It);
    Joint_semantics.read_result = (fun x x0 x1 st ->
    Obj.magic
      (Monad.m_return0 (Monad.max_def Errors.res0)
        (List.map
          (SemanticsUtils.hwreg_retrieve
            (Obj.magic st.Joint_semantics.regs).Types.snd)
          I8051.registerRets))); Joint_semantics.eval_ext_seq =
    (fun gl ge stm id -> eval_ertl_seq gl ge (Obj.magic stm) id);
    Joint_semantics.pop_frame = (fun x x0 x1 x2 -> ertl_pop_frame) }

(** val eRTL_semantics : SemanticsUtils.sem_graph_params **)
let eRTL_semantics =
  { SemanticsUtils.sgp_pars =
    (Joint.gp_to_p__o__stmt_pars__o__uns_pars ERTL.eRTL);
    SemanticsUtils.sgp_sup = (fun _ -> eRTL_sem_uns);
    SemanticsUtils.graph_pre_main_generator = ERTL.eRTL_premain }